Merge branch 'main' into convert_linetype_nas

teunbrand · web-flow · commit fd9830ef63b8 · 2025-03-25T10:26:49.000+01:00
diff --git a/NEWS.md b/NEWS.md
@@ -2,6 +2,10 @@
 
 * `linetype = NA` is now interpreted to mean 'no line' instead of raising errors
   (@teunbrand, #6269).
+* (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):
   * The `linewidth` aesthetic is now applied and replaces the `label.size` 
     argument.
@@ -304,10 +308,14 @@
   particularly for data-points with a low radius near the center 
   (@teunbrand, #5023).
 * All scales now expose the `aesthetics` parameter (@teunbrand, #5841)
+* Staged expressions are handled more gracefully if legends cannot resolve them 
+  (@teunbrand, #6264).
 * New `theme(legend.key.justification)` to control the alignment of legend keys 
   (@teunbrand, #3669). 
 * Added `scale_{x/y}_time(date_breaks, date_minor_breaks, date_labels)` 
   (@teunbrand, #4335).
+* `ggsave()` can write a multi-page pdf file when provided with a list of plots 
+  (@teunbrand, #5093).
 
 # ggplot2 3.5.1
 
diff --git a/R/geom-.R b/R/geom-.R
@@ -163,10 +163,15 @@ Geom <- ggproto("Geom",
     # If any after_scale mappings are detected they will be resolved here
     # This order means that they will have access to all default aesthetics
     if (length(modifiers) != 0) {
-      # Set up evaluation environment
-      modified_aes <- eval_aesthetics(
-        substitute_aes(modifiers), data,
-        mask = list(stage = stage_scaled)
+      modified_aes <- try_fetch(
+        eval_aesthetics(
+          substitute_aes(modifiers), data,
+          mask = list(stage = stage_scaled)
+        ),
+        error = function(cnd) {
+          cli::cli_warn("Unable to apply staged modifications.", parent = cnd)
+          data_frame0()
+        }
       )
 
       # Check that all output are valid data
@@ -177,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/geom-crossbar.R b/R/geom-crossbar.R
@@ -60,7 +60,7 @@ geom_crossbar <- function(mapping = NULL, data = NULL,
 #' @export
 GeomCrossbar <- ggproto("GeomCrossbar", Geom,
   setup_params = function(data, params) {
-    if (lifecycle::is_present(params$fatten)) {
+    if (lifecycle::is_present(params$fatten %||% deprecated())) {
       deprecate_soft0(
         "3.6.0", "geom_crossbar(fatten)",
         "geom_crossbar(middle.linewidth)"
diff --git a/R/geom-pointrange.R b/R/geom-pointrange.R
@@ -42,7 +42,7 @@ GeomPointrange <- ggproto("GeomPointrange", Geom,
   required_aes = c("x", "y", "ymin|xmin", "ymax|xmax"),
 
   setup_params = function(data, params) {
-    if (lifecycle::is_present(params$fatten)) {
+    if (lifecycle::is_present(params$fatten %||% deprecated())) {
       deprecate_soft0("3.6.0", "geom_pointrange(fatten)", I("the `size` aesthetic"))
     } else {
       # For backward compatibility reasons
diff --git a/R/geom-ribbon.R b/R/geom-ribbon.R
@@ -183,7 +183,7 @@ GeomRibbon <- ggproto("GeomRibbon", Geom,
     if ((length(aes$fill) > 1 || length(aes$alpha) > 1)) {
       transformed <- coord$transform(flip_data(data, flipped_aes), panel_params)
       if (flipped_aes) {
-        keep <- is.finite(tranformed$y)
+        keep <- is.finite(transformed$y)
         args <- list(
           colours = alpha(data$fill, data$alpha)[keep],
           stops = rescale(transformed$y)[keep],
diff --git 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,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, ...) {
@@ -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/position-nudge.R b/R/position-nudge.R
@@ -27,6 +27,11 @@
 #' ggplot(df, aes(x, y)) +
 #'   geom_point() +
 #'   geom_text(aes(label = y), nudge_y = -0.1)
+#'
+#' # For each text individually
+#' ggplot(df, aes(x, y)) +
+#'   geom_point() +
+#'   geom_text(aes(label = y, nudge_y = c(-0.1, 0.1, -0.1, 0.1)))
 position_nudge <- function(x = NULL, y = NULL) {
   ggproto(NULL, PositionNudge,
     x = x,
diff --git a/R/save.R b/R/save.R
@@ -101,17 +101,18 @@ ggsave <- function(filename, plot = get_last_plot(),
   dev <- validate_device(device, filename, dpi = dpi)
   dim <- plot_dim(c(width, height), scale = scale, units = units,
     limitsize = limitsize, dpi = dpi)
+  bg  <- get_plot_background(plot, bg)
 
-  if (is_null(bg)) {
-    bg <- calc_element("plot.background", plot_theme(plot))$fill %||% "transparent"
-  }
   old_dev <- grDevices::dev.cur()
   dev(filename = filename, width = dim[1], height = dim[2], bg = bg, ...)
   on.exit(utils::capture.output({
     grDevices::dev.off()
     if (old_dev > 1) grDevices::dev.set(old_dev) # restore old device unless null device
   }))
-  grid.draw(plot)
+  if (!is_bare_list(plot)) {
+    plot <- list(plot)
+  }
+  lapply(plot, grid.draw)
 
   invisible(filename)
 }
@@ -235,6 +236,17 @@ plot_dim <- function(dim = c(NA, NA), scale = 1, units = "in",
   dim
 }
 
+get_plot_background <- function(plot, bg = NULL, default = "transparent") {
+  if (!is.null(bg)) {
+    return(bg)
+  }
+  plot <- if (is_bare_list(plot)) plot[[1]] else plot
+  if (!is.ggplot(plot)) {
+    return(default)
+  }
+  calc_element("plot.background", plot_theme(plot))$fill %||% default
+}
+
 validate_device <- function(device, filename = NULL, dpi = 300, call = caller_env()) {
   force(filename)
   force(dpi)
diff --git a/R/scale-date.R b/R/scale-date.R
@@ -394,6 +394,9 @@ ScaleContinuousDatetime <- ggproto("ScaleContinuousDatetime", ScaleContinuous,
         i = "The value was converted to {obj_type_friendly(x)}."
       ), call = self$call)
     }
+    if (inherits(x, "Date")) {
+      x <- as.POSIXct(x)
+    }
     ggproto_parent(ScaleContinuous, self)$transform(x)
   },
   map = function(self, x, limits = self$get_limits()) {
@@ -441,6 +444,9 @@ ScaleContinuousDate <- ggproto("ScaleContinuousDate", ScaleContinuous,
         i = "The value was converted to {obj_type_friendly(x)}."
       ), call = self$call)
     }
+    if (inherits(x, "POSIXct")) {
+      x <- as.Date(x)
+    }
     ggproto_parent(ScaleContinuous, self)$transform(x)
   },
   get_breaks = function(self, limits = self$get_limits()) {
diff --git a/R/scale-linewidth.R b/R/scale-linewidth.R
@@ -2,7 +2,7 @@
 #'
 #' `scale_linewidth` scales the width of lines and polygon strokes. Due to
 #' historical reasons, it is also possible to control this with the `size`
-#' aesthetic, but using `linewidth` is encourage to clearly differentiate area
+#' aesthetic, but using `linewidth` is encouraged to clearly differentiate area
 #' aesthetics from stroke width aesthetics.
 #'
 #' @name scale_linewidth
diff --git 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
@@ -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/man/position_nudge.Rd b/man/position_nudge.Rd
diff --git a/man/scale_linewidth.Rd b/man/scale_linewidth.Rd
diff --git a/tests/testthat/_snaps/guide-legend.md b/tests/testthat/_snaps/guide-legend.md
@@ -0,0 +1,6 @@
+# unresolved, modified expressions throw a warning (#6264)
+
+    Unable to apply staged modifications.
+    Caused by error:
+    ! object 'prop' not found
+
diff --git a/tests/testthat/test-guide-legend.R b/tests/testthat/test-guide-legend.R
@@ -136,6 +136,15 @@ test_that("legends can be forced to display unrelated geoms", {
   )
 })
 
+test_that("unresolved, modified expressions throw a warning (#6264)", {
+  # Snapshot is unstable in lesser R versions
+  skip_if_not(getRversion() >= "4.3.0")
+  p <- ggplot(mpg, aes(drv)) +
+    geom_bar(
+      aes(fill = stage(drv, after_scale = alpha(fill, prop)))
+    )
+  expect_snapshot_warning(ggplot_build(p))
+})
 
 # Visual tests ------------------------------------------------------------
 
diff --git 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-scale_date.R b/tests/testthat/test-scale_date.R
@@ -1,4 +1,19 @@
 
+test_that("date(time) scales coerce data types", {
+
+  date     <- as.Date("2024-11-11")
+  datetime <- as.POSIXct(date)
+
+  sc <- scale_x_datetime()
+  df <- sc$transform_df(data_frame0(x = date))
+  expect_equal(df$x, as.numeric(datetime))
+
+  sc <- scale_x_date()
+  df <- sc$transform_df(data_frame0(x = datetime))
+  expect_equal(df$x, as.numeric(date))
+
+})
+
 # Visual tests ------------------------------------------------------------
 
 test_that("date scale draws correctly", {
diff --git 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")
+
+})
