Stability of layer data attributes

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)

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

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) {
@@ -414,29 +415,31 @@ 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,
       c(names(data), names(self$aes_params)),
       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, ...) {
@@ -499,6 +502,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)

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) {

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)

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 ---------------------------------------------------------