Intro Thoughts
StatCircle <- ggplot2::ggproto(
`_class` = "StatCircle",
`_inherit` = ggplot2::Stat,
compute_group = function(data, scales){},
required_aes = c("x0", "y0", "r"))
length(StatCircle)
## [1] 3
StatCircle2 <- ggplot2::ggproto(
`_class` = "StatCircle",
`_inherit` = ggplot2::Stat,
compute_panel = function(data, scales){},
required_aes = c("x0", "y0", "r"))
waldo::compare(StatCircle, StatCircle2)
## `names(old)`: "compute_group" "required_aes" "super"
## `names(new)`: "compute_panel" "required_aes" "super"
##
## `old$compute_group` is a function
## `new$compute_group` is absent
##
## `names(environment(old$super)$members)`: "compute_group" "required_aes"
## `names(environment(new$super)$members)`: "compute_panel" "required_aes"
##
## `environment(old$super)$members$compute_group` is a function
## `environment(new$super)$members$compute_group` is absent
##
## `environment(old$super)$members$compute_panel` is absent
## `environment(new$super)$members$compute_panel` is a function
##
## `old$compute_panel` is absent
## `new$compute_panel` is a function
Status Quo
library(tidyverse)
compute_panel_equilateral <- function(data, scales, n = 15){
data |>
mutate(group = row_number()) |>
crossing(tibble(z = 0:n)) |>
mutate(around = 2*pi*z/max(z)) |>
mutate(x = x0 + cos(around)*r,
y = y0 + sin(around)*r)
}
compute_group_default <- function (self, data, scales) {
cli::cli_abort("Not implemented.")
}
library(ggplot2)
compute_layer_default <- function (self, data, params, layout) {
ggplot2:::check_required_aesthetics(self$required_aes, c(names(data),
names(params)), ggplot2:::snake_class(self))
required_aes <- intersect(names(data), unlist(strsplit(self$required_aes,
"|", fixed = TRUE)))
data <- remove_missing(data, params$na.rm, c(required_aes,
self$non_missing_aes), ggplot2:::snake_class(self), finite = TRUE)
params <- params[intersect(names(params), self$parameters())]
args <- c(list(data = quote(data), scales = quote(scales)),
params)
ggplot2:::dapply(data, "PANEL", function(data) {
scales <- layout$get_scales(data$PANEL[1])
rlang::try_fetch(rlang::inject(self$compute_panel(data = data, scales = scales,
!!!params)), error = function(cnd) {
cli::cli_warn("Computation failed in {.fn {ggplot2:::snake_class(self)}}.",
parent = cnd)
ggplot2:::data_frame0()
})
})
}
StatCircle <- ggproto(
`_class` = "StatCircle",
`_inherit` = ggplot2::Stat,
# setup_data
compute_panel = compute_panel_equilateral,
compute_group = compute_group_default,
compute_layer = compute_layer_default,
# finish_layer =
# retransform
# extra_params =
# setup_params
# parameters
default_aes = ggplot2::aes(),
required_aes = character(),
dropped_aes = character(),
optional_aes = character(),
non_missing_aes = character(),
)
names(StatCircle)
## [1] "compute_layer" "non_missing_aes" "optional_aes" "default_aes"
## [5] "compute_panel" "super" "compute_group" "required_aes"
## [9] "dropped_aes"
Stat$compute_panel
## <ggproto method>
## <Wrapper function>
## function (...)
## compute_panel(..., self = self)
##
## <Inner function (f)>
## function (self, data, scales, ...)
## {
## if (empty(data))
## return(data_frame0())
## groups <- split(data, data$group)
## stats <- lapply(groups, function(group) {
## self$compute_group(data = group, scales = scales, ...)
## })
## non_constant_columns <- character(0)
## stats <- mapply(function(new, old) {
## if (empty(new))
## return(data_frame0())
## old <- old[, !(names(old) %in% names(new)), drop = FALSE]
## non_constant <- vapply(old, vec_unique_count, integer(1)) >
## 1L
## non_constant_columns <<- c(non_constant_columns, names(old)[non_constant])
## vec_cbind(new, old[rep(1, nrow(new)), , drop = FALSE])
## }, stats, groups, SIMPLIFY = FALSE)
## non_constant_columns <- unique0(non_constant_columns)
## dropped <- non_constant_columns[!non_constant_columns %in%
## self$dropped_aes]
## if (length(dropped) > 0) {
## cli::cli_warn(c("The following aesthetics were dropped during statistical transformation: {.field {dropped}}.",
## i = "This can happen when ggplot fails to infer the correct grouping structure in the data.",
## i = "Did you forget to specify a {.code group} aesthetic or to convert a numerical variable into a factor?"))
## }
## data_new <- vec_rbind0(!!!stats)
## data_new[, !names(data_new) %in% non_constant_columns, drop = FALSE]
## }
geom_circle <- function(
mapping = NULL,
data = NULL,
position = "identity",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE, ...) {
ggplot2::layer(
stat = StatCircle, # proto object from Step 2
geom = ggplot2::GeomPolygon, # inherit other behavior
data = data,
mapping = mapping,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}
tictoc::tic()
data.frame(x0 = 0:1, y0 = 0:1, r = 1:2/3) |>
ggplot() +
aes(x0 = x0, y0 = y0, r = r) +
geom_circle() +
aes(fill = r)
tictoc::toc()
## 0.457 sec elapsed
tictoc::tic()
last_plot()
tictoc::toc()
## 0.542 sec elapsed
ggtemp:::create_layer_temp("geom_circle2",
compute_panel = compute_panel_equilateral,
required_aes = c("x0", "y0", "r"))
tictoc::tic()
data.frame(x0 = 0:1, y0 = 0:1, r = 1:2/3) |>
ggplot() +
aes(x0 = x0, y0 = y0, r = r) +
geom_circle2() +
aes(fill = r)
tictoc::toc()
## 0.411 sec elapsed