From 3408ea4d51b459cc00c63875527edf1a996b66d1 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 20 Nov 2024 16:16:41 +0100 Subject: [PATCH 1/4] prevent dropping attributes --- R/geom-.R | 5 +---- R/layer.R | 8 ++++++-- R/scales-.R | 3 ++- 3 files changed, 9 insertions(+), 7 deletions(-) diff --git a/R/geom-.R b/R/geom-.R index dae3027e1b..2c787b7f13 100644 --- a/R/geom-.R +++ b/R/geom-.R @@ -183,10 +183,7 @@ Geom <- ggproto("Geom", } modified_aes <- cleanup_mismatched_data(modified_aes, nrow(data), "after_scale") - - modified_aes <- data_frame0(!!!modified_aes) - - data <- data_frame0(!!!defaults(modified_aes, data)) + data[names(modified_aes)] <- modified_aes } # Override mappings with params diff --git a/R/layer.R b/R/layer.R index 639fece4af..3e4eef6267 100644 --- a/R/layer.R +++ b/R/layer.R @@ -414,8 +414,8 @@ Layer <- ggproto("Layer", NULL, stat_data <- plot$scales$transform_df(stat_data) } stat_data <- cleanup_mismatched_data(stat_data, nrow(data), "after_stat") - - data_frame0(!!!defaults(stat_data, data)) + data[names(stat_data)] <- stat_data + data }, compute_geom_1 = function(self, data) { @@ -499,6 +499,10 @@ set_draw_key <- function(geom, draw_key = NULL) { } cleanup_mismatched_data <- function(data, n, fun) { + if (vec_duplicate_any(names(data))) { + data <- data[unique0(names(data))] + } + failed <- !lengths(data) %in% c(0, 1, n) if (!any(failed)) { return(data) diff --git a/R/scales-.R b/R/scales-.R index e62eb0e8cb..4a94b6490b 100644 --- a/R/scales-.R +++ b/R/scales-.R @@ -78,7 +78,8 @@ ScalesList <- ggproto("ScalesList", NULL, function(scale) scale$map_df(df = df) ), recursive = FALSE) - data_frame0(!!!mapped, df[setdiff(names(df), names(mapped))]) + df[names(mapped)] <- mapped + df }, transform_df = function(self, df) { From 468563bc991b30312c92e85a352c7558ca490233 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 21 Nov 2024 11:09:54 +0100 Subject: [PATCH 2/4] restore attributes after layer methods --- R/layer.R | 17 ++++++++++------- R/utilities.R | 8 ++++++++ 2 files changed, 18 insertions(+), 7 deletions(-) diff --git a/R/layer.R b/R/layer.R index 3e4eef6267..19e417c51a 100644 --- a/R/layer.R +++ b/R/layer.R @@ -359,12 +359,13 @@ Layer <- ggproto("Layer", NULL, }, compute_statistic = function(self, data, layout) { - if (empty(data)) - return(data_frame0()) + if (empty(data)) return(data_frame0()) + ptype <- vec_ptype(data) self$computed_stat_params <- self$stat$setup_params(data, self$stat_params) data <- self$stat$setup_data(data, self$computed_stat_params) - self$stat$compute_layer(data, self$computed_stat_params, layout) + data <- self$stat$compute_layer(data, self$computed_stat_params, layout) + merge_attrs(data, ptype) }, map_statistic = function(self, data, plot) { @@ -420,6 +421,7 @@ Layer <- ggproto("Layer", NULL, compute_geom_1 = function(self, data) { if (empty(data)) return(data_frame0()) + ptype <- vec_ptype(data) check_required_aesthetics( self$geom$required_aes, @@ -427,16 +429,17 @@ Layer <- ggproto("Layer", NULL, snake_class(self$geom) ) self$computed_geom_params <- self$geom$setup_params(data, c(self$geom_params, self$aes_params)) - self$geom$setup_data(data, self$computed_geom_params) + data <- self$geom$setup_data(data, self$computed_geom_params) + merge_attrs(data, ptype) }, compute_position = function(self, data, layout) { if (empty(data)) return(data_frame0()) - + ptype <- vec_ptype(data) params <- self$position$setup_params(data) data <- self$position$setup_data(data, params) - - self$position$compute_layer(data, params, layout) + data <- self$position$compute_layer(data, params, layout) + merge_attrs(data, ptype) }, compute_geom_2 = function(self, data, params = self$aes_params, theme = NULL, ...) { diff --git a/R/utilities.R b/R/utilities.R index 039376f4df..4bdbb5736d 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -249,6 +249,14 @@ toupper <- function(x) { cli::cli_abort("Please use {.fn to_upper_ascii}, which works fine in all locales.") } +merge_attrs <- function(new, old) { + new_attr <- attributes(new) + new <- vec_restore(new, old) # copies old attributes to new + new_attr <- new_attr[setdiff(names(new_attr), names(attributes(new)))] + attributes(new) <- c(attributes(new), new_attr) + new +} + # Convert a snake_case string to camelCase camelize <- function(x, first = FALSE) { x <- gsub("_(.)", "\\U\\1", x, perl = TRUE) From 080fc6f293f32922d62e99a28c075d734c197e69 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 21 Nov 2024 11:10:23 +0100 Subject: [PATCH 3/4] add test --- tests/testthat/test-layer.R | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/tests/testthat/test-layer.R b/tests/testthat/test-layer.R index 964211a4ee..de95f032e6 100644 --- a/tests/testthat/test-layer.R +++ b/tests/testthat/test-layer.R @@ -154,6 +154,28 @@ test_that("layer names can be resolved", { expect_snapshot(p + l + l, error = TRUE) }) +test_that("attributes on layer data are preserved", { + # This is a good layer for testing because: + # * It needs to compute a statistic at the group level + # * It needs to setup data to reshape x/y/width/height into xmin/xmax/ymin/ymax + # * It needs to use a position adjustment + # * It has an `after_stat()` so it enters the map_statistic method + old <- stat_summary( + aes(fill = after_stat(y)), + fun = mean, geom = "col", position = "dodge" + ) + # We modify the compute aesthetics method to append a test attribute + new <- ggproto(NULL, old, compute_aesthetics = function(self, data, plot) { + data <- ggproto_parent(old, self)$compute_aesthetics(data, plot) + attr(data, "test") <- "preserve me" + data + }) + # At the end of plot building, we want to retrieve that metric + ld <- layer_data( + ggplot(mpg, aes(drv, hwy, colour = factor(year))) + new + facet_grid(~year) + ) + expect_equal(attr(ld, "test"), "preserve me") +}) # Data extraction --------------------------------------------------------- From 67a2a0ef0af950c912b8234efcf850b6d063b083 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 21 Nov 2024 11:21:54 +0100 Subject: [PATCH 4/4] add news bullet --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS.md b/NEWS.md index 0c493a8f58..f15521bd87 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* (internal) layer data can be attenuated with parameter attributes + (@teunbrand, #3175). * Custom and raster annotation now respond to scale transformations, and can use AsIs variables for relative placement (@teunbrand based on @yutannihilation's prior work, #3120)