From 3c17dc9f806f53d253ef2f36b2dfe73c94fac69e Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 20 Sep 2024 16:54:46 +0200 Subject: [PATCH 1/4] add lookup via constructor --- R/layer.R | 49 ++++++++++++++++++++++++++++++++++++------------- 1 file changed, 36 insertions(+), 13 deletions(-) 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 From 6ad4e0221a94e8c7d41f18b0eee8406fac9340d2 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 20 Sep 2024 16:54:51 +0200 Subject: [PATCH 2/4] add tests --- tests/testthat/test-layer.R | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) 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 --------------------------------------------------------- From 206a3c948a2e8508259aeeb207d75af201c3c738 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 20 Sep 2024 16:55:44 +0200 Subject: [PATCH 3/4] add news bullet --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) 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 From 1473af083cac18027bddfcb196b215231f698d43 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 24 Mar 2025 17:54:47 +0100 Subject: [PATCH 4/4] catch errors when constructor needs arguments --- R/layer.R | 11 ++++++++++- tests/testthat/_snaps/layer.md | 6 ++++++ tests/testthat/test-layer.R | 3 +++ 3 files changed, 19 insertions(+), 1 deletion(-) diff --git a/R/layer.R b/R/layer.R index 9aed49ca7f..b06654a134 100644 --- a/R/layer.R +++ b/R/layer.R @@ -471,7 +471,16 @@ validate_subclass <- function(x, subclass, name <- snakeize(name) obj <- find_global(name, env = env, mode = "function") if (is.function(obj)) { - obj <- obj() + obj <- try_fetch( + obj(), + error = function(cnd) { + # replace `obj()` call with name of actual constructor + cnd$call <- call(name) + cli::cli_abort( + "Failed to retrieve a {.cls {subclass}} object from {.fn {name}}.", + parent = cnd, call = call + ) + }) } # Position constructors return classes directly if (inherits(obj, subclass)) { diff --git a/tests/testthat/_snaps/layer.md b/tests/testthat/_snaps/layer.md index f5f3ee9616..c796c6a530 100644 --- a/tests/testthat/_snaps/layer.md +++ b/tests/testthat/_snaps/layer.md @@ -27,6 +27,12 @@ `environment()` must be either a string or a object, not an environment. +--- + + Failed to retrieve a object from `geom_foo()`. + Caused by error in `geom_foo()`: + ! This function is unconstructable. + # unknown params create warning Ignoring unknown parameters: `blah` diff --git a/tests/testthat/test-layer.R b/tests/testthat/test-layer.R index f2a6565199..06ba3e623d 100644 --- a/tests/testthat/test-layer.R +++ b/tests/testthat/test-layer.R @@ -10,6 +10,9 @@ test_that("layer() checks its input", { expect_snapshot_error(validate_subclass("test", "geom")) expect_snapshot_error(validate_subclass(environment(), "geom")) + + geom_foo <- function(...) stop("This function is unconstructable.") + expect_snapshot_error(layer("foo", "identity", position = "identity")) }) test_that("aesthetics go in aes_params", {