From 5a7b9ed435f9d5addb5069de1b13351612bf7673 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 17 Sep 2024 09:46:29 +0200 Subject: [PATCH 1/7] evaluation helper --- R/aes-evaluation.R | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/R/aes-evaluation.R b/R/aes-evaluation.R index 5554b54772..346c53cd16 100644 --- a/R/aes-evaluation.R +++ b/R/aes-evaluation.R @@ -359,3 +359,17 @@ make_labels <- function(mapping) { } Map(default_label, names(mapping), mapping) } + +eval_aesthetics <- function(aesthetics, data, mask = NULL) { + + env <- child_env(base_env()) + + syntax <- list(stage = stage, after_stat = after_stat, after_scale = after_scale) + mask <- child_env(empty_env(), !!!defaults(mask, syntax)) + mask <- new_data_mask(as_environment(data, mask), mask) + mask$.data <- as_data_pronoun(mask) + + evaled <- lapply(aesthetics, eval_tidy, data = mask, env = env) + names(evaled) <- names(aesthetics) + compact(rename_aes(evaled)) +} From ba1740aafd38860fd7bd41764fc7eabb1203a9b1 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 17 Sep 2024 09:46:55 +0200 Subject: [PATCH 2/7] use helper --- R/geom-.R | 14 +++++--------- R/layer.R | 24 ++++++++---------------- 2 files changed, 13 insertions(+), 25 deletions(-) diff --git a/R/geom-.R b/R/geom-.R index 5b6a2af09d..2cef655f38 100644 --- a/R/geom-.R +++ b/R/geom-.R @@ -157,12 +157,10 @@ Geom <- ggproto("Geom", # This order means that they will have access to all default aesthetics if (length(modifiers) != 0) { # Set up evaluation environment - env <- child_env(baseenv(), after_scale = after_scale) - # Mask stage with stage_scaled so it returns the correct expression - stage_mask <- child_env(emptyenv(), stage = stage_scaled) - mask <- new_data_mask(as_environment(data, stage_mask), stage_mask) - mask$.data <- as_data_pronoun(mask) - modified_aes <- lapply(substitute_aes(modifiers), eval_tidy, mask, env) + modified_aes <- eval_aesthetics( + substitute_aes(modifiers), data, + mask = list(stage = stage_scaled) + ) # Check that all output are valid data nondata_modified <- check_nondata_cols(modified_aes) @@ -177,11 +175,9 @@ Geom <- ggproto("Geom", )) } - names(modified_aes) <- names(rename_aes(modifiers)) - modified_aes <- cleanup_mismatched_data(modified_aes, nrow(data), "after_scale") - modified_aes <- data_frame0(!!!compact(modified_aes)) + modified_aes <- data_frame0(!!!modified_aes) data <- cunion(modified_aes, data) } diff --git a/R/layer.R b/R/layer.R index 8acb438c9e..6685e4cb18 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 @@ -303,10 +303,7 @@ Layer <- ggproto("Layer", NULL, } # Evaluate aesthetics - env <- child_env(baseenv(), stage = stage) - evaled <- lapply(aesthetics, eval_tidy, data = data, env = env) - evaled <- compact(evaled) - + evaled <- eval_aesthetics(aesthetics, data) plot$scales$add_defaults(evaled, plot$plot_env) # Check for discouraged usage in mapping @@ -386,14 +383,10 @@ Layer <- ggproto("Layer", NULL, data_orig <- plot$scales$backtransform_df(data) # Add map stat output to aesthetics - env <- child_env(baseenv(), stat = stat, after_stat = after_stat) - stage_mask <- child_env(emptyenv(), stage = stage_calculated) - mask <- new_data_mask(as_environment(data_orig, stage_mask), stage_mask) - mask$.data <- as_data_pronoun(mask) - - new <- substitute_aes(new) - stat_data <- lapply(new, eval_tidy, mask, env) - + stat_data <- eval_aesthetics( + substitute_aes(new), data_orig, + mask = list(stage = stage_calculated) + ) # Check that all columns in aesthetic stats are valid data nondata_stat_cols <- check_nondata_cols(stat_data) if (length(nondata_stat_cols) > 0) { @@ -407,8 +400,7 @@ Layer <- ggproto("Layer", NULL, )) } - names(stat_data) <- names(new) - stat_data <- data_frame0(!!!compact(stat_data)) + stat_data <- data_frame0(!!!stat_data) # Add any new scales, if needed plot$scales$add_defaults(stat_data, plot$plot_env) From 55957b8b7db3f21bd29e1a1dc59c6c4d64bda749 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 23 Sep 2024 11:25:46 +0200 Subject: [PATCH 3/7] generalise `substitute_aes()` --- R/aes.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/aes.R b/R/aes.R index 4120657222..52e7cf52b6 100644 --- a/R/aes.R +++ b/R/aes.R @@ -189,9 +189,9 @@ rename_aes <- function(x) { } x } -substitute_aes <- function(x) { +substitute_aes <- function(x, fun = standardise_aes_symbols, ...) { x <- lapply(x, function(aesthetic) { - as_quosure(standardise_aes_symbols(quo_get_expr(aesthetic)), env = environment(aesthetic)) + as_quosure(fun(quo_get_expr(aesthetic), ...), env = environment(aesthetic)) }) class(x) <- "uneval" x From cf078780ef75621cec6a076025ccbc292409d673 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 23 Sep 2024 11:55:18 +0200 Subject: [PATCH 4/7] substitute expressions instead of wrangling data masks --- R/aes-evaluation.R | 32 +++++++++++++++++++++++++++----- 1 file changed, 27 insertions(+), 5 deletions(-) diff --git a/R/aes-evaluation.R b/R/aes-evaluation.R index 346c53cd16..ffbf370d79 100644 --- a/R/aes-evaluation.R +++ b/R/aes-evaluation.R @@ -364,12 +364,34 @@ eval_aesthetics <- function(aesthetics, data, mask = NULL) { env <- child_env(base_env()) - syntax <- list(stage = stage, after_stat = after_stat, after_scale = after_scale) - mask <- child_env(empty_env(), !!!defaults(mask, syntax)) - mask <- new_data_mask(as_environment(data, mask), mask) - mask$.data <- as_data_pronoun(mask) + # Here we mask functions, often to replace `stage()` with context appropriate + # functions `stage_calculated()`/`stage_scaled()`. + if (length(mask) > 0) { + aesthetics <- substitute_aes(aesthetics, mask_function, mask = mask) + } - evaled <- lapply(aesthetics, eval_tidy, data = mask, env = env) + evaled <- lapply(aesthetics, eval_tidy, data = data, env = env) names(evaled) <- names(aesthetics) compact(rename_aes(evaled)) } + +# `mask` is a list of functions where `names(mask)` indicate names of functions +# that need to be replaced, and `mask[[i]]` is the function to replace it +# with. +mask_function <- function(x, mask) { + if (!is.call(x)) { + return(x) + } + nms <- names(mask) + x[-1] <- lapply(x[-1], mask_function, mask = mask) + if (!is_call(x, nms)) { + return(x) + } + for (nm in nms) { + if (is_call(x, nm)) { + x[[1]] <- mask[[nm]] + return(x) + } + } +} + From 24b6f205a7ecb6a3619a8f6380ee18568097a8c6 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 23 Sep 2024 12:26:57 +0200 Subject: [PATCH 5/7] add test --- tests/testthat/test-aes-calculated.R | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/tests/testthat/test-aes-calculated.R b/tests/testthat/test-aes-calculated.R index b453af02f5..3ac8e06dbe 100644 --- a/tests/testthat/test-aes-calculated.R +++ b/tests/testthat/test-aes-calculated.R @@ -99,3 +99,28 @@ test_that("A deprecated warning is issued when stat(var) or ..var.. is used", { p2 <- ggplot(NULL, aes(..bar..)) expect_snapshot_warning(b2 <- ggplot_build(p2)) }) + +test_that("functions can be masked", { + + foo <- function(x) x + 10 + bar <- function(x) x * 10 + + data <- data.frame(val = 10) + mapping <- aes(x = val, y = foo(20)) + + evaled <- eval_aesthetics(mapping, data = data, mask = list()) + expect_equal(evaled, list(x = 10, y = 30)) + + evaled <- eval_aesthetics(mapping, data = data, mask = list(foo = bar)) + expect_equal(evaled, list(x = 10, y = 200)) + + # Test namespace-prefixed evaluation (#6104) + mapping <- aes(x = val, y = ggplot2::stage(10, 20, 30)) + evaled <- eval_aesthetics(mapping, data = data, mask = list()) + expect_equal(evaled, list(x = 10, y = 10)) + evaled <- eval_aesthetics(mapping, data = data, mask = list(stage = stage_calculated)) + expect_equal(evaled, list(x = 10, y = 20)) + evaled <- eval_aesthetics(mapping, data = data, mask = list(stage = stage_scaled)) + expect_equal(evaled, list(x = 10, y = 30)) + +}) From 97135956920d3f2d3e58d4eac69dda99d9457135 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 23 Sep 2024 12:30:44 +0200 Subject: [PATCH 6/7] make a comment for the next person to trip over this --- R/aes.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/aes.R b/R/aes.R index 52e7cf52b6..17e30adba0 100644 --- a/R/aes.R +++ b/R/aes.R @@ -189,6 +189,9 @@ rename_aes <- function(x) { } x } + +# `x` is assumed to be a strict list of quosures; +# it should have no non-quosure constants in it, even though `aes()` allows it. substitute_aes <- function(x, fun = standardise_aes_symbols, ...) { x <- lapply(x, function(aesthetic) { as_quosure(fun(quo_get_expr(aesthetic), ...), env = environment(aesthetic)) From cc0b2ea0564e02218ff2a8fd9635e6abdb9cc9dd Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 23 Sep 2024 13:32:37 +0200 Subject: [PATCH 7/7] add news bullet --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS.md b/NEWS.md index 5df6059f0f..b5d40cf8e6 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* Fixed bug where the `ggplot2::`-prefix did not work with `stage()` + (@teunbrand, #6104). * 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