diff --git a/NEWS.md b/NEWS.md index 67d35b9878..da280f144a 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). * Date scales silently coerce to and datetime scales silently coerce to (@laurabrianna, #3533) * New parameters for `geom_label()` (@teunbrand and @steveharoz, #5365): diff --git a/R/geom-.R b/R/geom-.R index 843bd4c11c..c19b1f3458 100644 --- a/R/geom-.R +++ b/R/geom-.R @@ -182,10 +182,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 6be74b5d72..2cd10c447f 100644 --- a/R/layer.R +++ b/R/layer.R @@ -347,12 +347,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) { @@ -396,12 +397,13 @@ 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) { if (empty(data)) return(data_frame0()) + ptype <- vec_ptype(data) check_required_aesthetics( self$geom$required_aes, @@ -409,17 +411,18 @@ 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) data <- self$position$use_defaults(data, self$aes_params) 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, ...) { @@ -484,6 +487,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 87c5f6f586..6c14347f49 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) { @@ -104,7 +105,8 @@ ScalesList <- ggproto("ScalesList", NULL, function(scale) scale$transform_df(df = df) ), recursive = FALSE) - data_frame0(!!!transformed, df[setdiff(names(df), names(transformed))]) + df[names(transformed)] <- transformed + df }, backtransform_df = function(self, df) { @@ -139,10 +141,8 @@ ScalesList <- ggproto("ScalesList", NULL, } ), recursive = FALSE) - data_frame0( - !!!backtransformed, - df[setdiff(names(df), names(backtransformed))] - ) + df[names(backtransformed)] <- backtransformed + df }, # `aesthetics` is a list of aesthetic-variable mappings. The name of each diff --git a/R/utilities.R b/R/utilities.R index 3bcdaacedc..51798059c8 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) diff --git a/tests/testthat/test-layer.R b/tests/testthat/test-layer.R index 59970c7db5..f901d3b62f 100644 --- a/tests/testthat/test-layer.R +++ b/tests/testthat/test-layer.R @@ -154,6 +154,29 @@ 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) + + scale_y_sqrt() + ) + expect_equal(attr(ld, "test"), "preserve me") +}) # Data extraction --------------------------------------------------------- diff --git a/tests/testthat/test-stats.R b/tests/testthat/test-stats.R index 8545b485fd..f8e8b37f31 100644 --- a/tests/testthat/test-stats.R +++ b/tests/testthat/test-stats.R @@ -69,3 +69,22 @@ test_that("erroneously dropped aesthetics are found and issue a warning", { c(TRUE, FALSE, FALSE) ) }) + +test_that("stats can modify persistent attributes", { + + StatTest <- ggproto( + "StatTest", Stat, + compute_layer = function(self, data, params, layout) { + attr(data, "foo") <- "bar" + data + } + ) + + p <- ggplot(mtcars, aes(disp, mpg)) + + geom_point(stat = StatTest) + + facet_wrap(~cyl) + + ld <- layer_data(p) + expect_equal(attr(ld, "foo"), "bar") + +})