diff --git a/NEWS.md b/NEWS.md index 5df6059f0f..e2fdbd6d1e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* When `check_subclass()` fails to find a class directly, it tries to retrieve + the class via constructor functions. * Built-in `theme_*()` functions now have `ink` and `paper` arguments to control foreground and background colours respectively (@teunbrand) * The `summary()` method for ggplots is now more terse about facets diff --git a/R/layer.R b/R/layer.R index 8acb438c9e..61a66a51da 100644 --- a/R/layer.R +++ b/R/layer.R @@ -58,8 +58,8 @@ #' `NA`, the default, includes if any aesthetics are mapped. #' `FALSE` never includes, and `TRUE` always includes. #' It can also be a named logical vector to finely select the aesthetics to -#' display. To include legend keys for all levels, even -#' when no data exists, use `TRUE`. If `NA`, all levels are shown in legend, +#' display. To include legend keys for all levels, even +#' when no data exists, use `TRUE`. If `NA`, all levels are shown in legend, #' but unobserved levels are omitted. #' @param inherit.aes If `FALSE`, overrides the default aesthetics, #' rather than combining with them. This is most useful for helper functions @@ -475,19 +475,42 @@ check_subclass <- function(x, subclass, env = parent.frame(), call = caller_env()) { if (inherits(x, subclass)) { - x - } else if (is_scalar_character(x)) { - name <- paste0(subclass, camelize(x, first = TRUE)) - obj <- find_global(name, env = env) - - if (is.null(obj) || !inherits(obj, subclass)) { - cli::cli_abort("Can't find {argname} called {.val {x}}.", call = call) - } else { - obj - } - } else { + return(x) + } + if (!is_scalar_character(x)) { stop_input_type(x, as_cli("either a string or a {.cls {subclass}} object")) } + + # Try getting class object directly + name <- paste0(subclass, camelize(x, first = TRUE)) + obj <- find_global(name, env = env) + if (inherits(obj, subclass)) { + return(obj) + } + + # Try retrieving class via constructors + name <- snakeize(name) + obj <- find_global(name, env = env, mode = "function") + if (is.function(obj)) { + obj <- obj() + } + # Position constructors return classes directly + if (inherits(obj, subclass)) { + return(obj) + } + # Try prying the class from a layer + if (inherits(obj, "Layer")) { + obj <- switch( + subclass, + Geom = obj$geom, + Stat = obj$stat, + NULL + ) + } + if (inherits(obj, subclass)) { + return(obj) + } + cli::cli_abort("Can't find {argname} called {.val {x}}.", call = call) } # helper function to adjust the draw_key slot of a geom diff --git a/tests/testthat/test-layer.R b/tests/testthat/test-layer.R index 51f0cd9eee..893c061c77 100644 --- a/tests/testthat/test-layer.R +++ b/tests/testthat/test-layer.R @@ -160,6 +160,22 @@ test_that("layer names can be resolved", { ) }) +test_that("check_subclass can resolve classes via constructors", { + + env <- new_environment(list( + geom_foobar = geom_point, + stat_foobar = stat_boxplot, + position_foobar = position_nudge, + guide_foobar = guide_axis_theta + )) + + expect_s3_class(check_subclass("foobar", "Geom", env = env), "GeomPoint") + expect_s3_class(check_subclass("foobar", "Stat", env = env), "StatBoxplot") + expect_s3_class(check_subclass("foobar", "Position", env = env), "PositionNudge") + expect_s3_class(check_subclass("foobar", "Guide", env = env), "GuideAxisTheta") + +}) + # Data extraction ---------------------------------------------------------