Merge branch 'main' into check_subclass_fallback

Author: teunbrand

NEWS.md

@@ -1,5 +1,7 @@
 # ggplot2 (development version)
 
+* (internal) layer data can be attenuated with parameter attributes 
+  (@teunbrand, #3175).
 * Date scales silently coerce <POSIXct> to <Date> and datetime scales silently
   coerce <Date> to <POSIXct> (@laurabrianna, #3533)
 * New parameters for `geom_label()` (@teunbrand and @steveharoz, #5365):

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

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,30 +397,32 @@ 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)
     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, ...) {
@@ -516,6 +519,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) {
@@ -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

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

@@ -173,6 +173,29 @@ test_that("check_subclass can resolve classes via constructors", {
 
 })
 
+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 ---------------------------------------------------------
 

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")
+
+})