Polishes triggered by revdep failures (#6506)

* don't extract <element_blank>@hjust

* ensure `if` switch is scalar

* contingency where `merge_element(..., e2 = <S3_element>)`

* cast a wider net for function matching

* Fix NOTE: no visible binding for global variable 'properties'

* stabilise missingness detection for 2D structures

* avoid recursion issue when `theme` is missing

* avoid renaming argument for S3 method consistency purposes

* demote warning to message

* stop complaints about 0-length labels, which is commonly used in label supression

* allow merging <S3> + <S3>

* fix #6521

* fix #6513

* avoid rare error when using GeomSf based extensions

* `label.size` should be soft-deprecated first

* put `convert` into `local()` too

* restore accent colour for `geom_contour()`

* new revdepcheck

* don't prepend `""` as class

* mark the binning change as a breaking change

* fix #6531

* fix #6529

* no longer soft-deprecated

* attempt to tone down spurious warnings

* fallback for translating `geom_errorbarh(height)`

* alias to prevent breaking linking docs

* avoid `rel(0)` margins, fix #6536

* last attempt at removing rownames

* use logical NA for casting purposes

---------

Co-authored-by: Thomas Lin Pedersen <thomasp85@gmail.com>

Author: teunbrand

NEWS.md

@@ -25,6 +25,9 @@
   rather than in the layer method of `update_ggplot()` 
   (previously `ggplot_add.Layer()`). This may affect code that accessed the 
   `plot$labels` property (@teunbrand, #5894).
+* In binning stats, the default `boundary` is now chosen to better adhere to
+  the `nbin` argument. This may affect plots that use default binning
+  (@teunbrand, #5882, #5036)
 
 ### Lifecycle changes
 
@@ -218,8 +221,6 @@
   aesthetics (@teunbrand, #2800, #3142, #5740, #3722).
 * All binning stats now use the `boundary`/`center` parametrisation rather
   than `origin`, following in `stat_bin()`'s footsteps (@teunbrand).
-* In `stat_bin()`, the default `boundary` is now chosen to better adhere to
-  the `nbin` argument (@teunbrand, #5882, #5036)
 * Reintroduced `drop` argument to `stat_bin()` (@teunbrand, #3449)
 * `stat_bin()` now accepts functions for argument `breaks` (@aijordan, #4561)
 * `after_stat()` and `after_scale()` throw warnings when the computed aesthetics

R/aes.R

@@ -261,7 +261,7 @@ is_position_aes <- function(vars) {
 #'
 #' @section Life cycle:
 #'
-#' All these functions are soft-deprecated. Please use tidy evaluation idioms
+#' All these functions are deprecated. Please use tidy evaluation idioms
 #' instead. Regarding `aes_string()`, you can replace it with `.data` pronoun.
 #' For example, the following code can achieve the same mapping as
 #' `aes_string(x_var, y_var)`.

R/compat-plyr.R

@@ -19,7 +19,17 @@ unrowname <- function(x) {
   } else if (is.matrix(x)) {
     dimnames(x)[1] <- list(NULL)
   } else {
-    cli::cli_abort("Can only remove rownames from {.cls data.frame} and {.cls matrix} objects.")
+    try_fetch(
+      {
+        rownames(x) <- NULL
+      },
+      error = function(cnd) {
+        cli::cli_abort(
+          "Can only remove rownames from {.cls data.frame} and {.cls matrix} objects.",
+          parent = cnd
+        )
+      }
+    )
   }
   x
 }

R/coord-radial.R

@@ -136,7 +136,7 @@ coord_radial <- function(theta = "x",
   }
   if (lifecycle::is_present(direction)) {
     deprecate_warn0(
-      "3.5.2", "coord_radial(direction)", "coord_radial(reverse)"
+      "4.0.0", "coord_radial(direction)", "coord_radial(reverse)"
     )
     reverse <- switch(reverse, "r" = "thetar", "theta")
   }

R/coord-transform.R

@@ -113,7 +113,7 @@ coord_transform <- function(x = "identity", y = "identity", xlim = NULL, ylim =
 #' @export
 coord_trans <- function(...) {
   deprecate_soft0(
-    "3.5.2",
+    "4.0.0",
     "coord_trans()",
     "coord_transform()"
   )

R/facet-wrap.R

@@ -569,7 +569,7 @@ wrap_layout <- function(id, dims, dir) {
     # Should only occur when `as.table` was not incorporated into `dir`
     dir <- switch(dir, h = "lt", v = "tl")
     deprecate_soft0(
-      "3.5.2",
+      "4.0.0",
       what = I("Internal use of `dir = \"h\"` and `dir = \"v\"` in `facet_wrap()`"),
       details = I(c(
         "The `dir` argument should incorporate the `as.table` argument.",

R/geom-boxplot.R

@@ -241,7 +241,7 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom,
   setup_params = function(data, params) {
     if ("fatten" %in% names(params)) {
       deprecate_soft0(
-        "3.6.0", "geom_boxplot(fatten)",
+        "4.0.0", "geom_boxplot(fatten)",
         "geom_boxplot(median.linewidth)"
       )
     } else {

R/geom-contour.R

@@ -5,7 +5,13 @@
 #' @include geom-path.R
 GeomContour <- ggproto(
   "GeomContour", GeomPath,
-  default_aes = aes(weight = 1, !!!GeomPath$default_aes)
+  default_aes = aes(
+    weight = 1,
+    colour = from_theme(colour %||% accent),
+    linewidth = from_theme(linewidth),
+    linetype = from_theme(linetype),
+    alpha = NA
+  )
 )
 
 #' @rdname Geom

R/geom-crossbar.R

@@ -62,7 +62,7 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom,
   setup_params = function(data, params) {
     if (lifecycle::is_present(params$fatten %||% deprecated())) {
       deprecate_soft0(
-        "3.6.0", "geom_crossbar(fatten)",
+        "4.0.0", "geom_crossbar(fatten)",
         "geom_crossbar(middle.linewidth)"
       )
     } else {

R/geom-density.R

@@ -76,7 +76,7 @@ GeomDensity <- ggproto(
 #'   geom_density(position = "fill")
 #' }
 geom_density <- make_constructor(
-  GeomDensity, stat = "density",
+  GeomDensity, stat = "density", outline.type = "upper",
   checks = exprs(
     outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full"))
   )

R/geom-errorbar.R

@@ -18,10 +18,19 @@ GeomErrorbar <- ggproto(
   required_aes = c("x|y", "ymin|xmin", "ymax|xmax"),
 
   setup_params = function(data, params) {
-    GeomLinerange$setup_params(data, params)
+    params <- GeomLinerange$setup_params(data, params)
+    if (
+      isTRUE(params$flipped_aes) &&
+      isTRUE("height" %in% names(params)) &&
+      !isTRUE("width" %in% names(params))
+    ) {
+      params <- rename(params, c(height = "width"))
+      cli::cli_inform("{.arg height} was translated to {.arg width}.")
+    }
+    params
   },
 
-  extra_params = c("na.rm", "orientation"),
+  extra_params = c("na.rm", "orientation", "height"),
 
   setup_data = function(self, data, params) {
     data$flipped_aes <- params$flipped_aes
@@ -69,7 +78,7 @@ GeomErrorbarh <- ggproto(
   "GeomErrorbarh", GeomErrorbar,
   setup_params = function(data, params) {
     deprecate_soft0(
-      "3.5.2", "geom_errobarh()", "geom_errorbar(orientation = \"y\")",
+      "4.0.0", "geom_errobarh()", "geom_errorbar(orientation = \"y\")",
       id = "no-more-errorbarh"
     )
     GeomLinerange$setup_params(data, params)
@@ -87,7 +96,7 @@ geom_errorbar <- make_constructor(GeomErrorbar, orientation = NA)
 #' `geom_errorbar(orientation = "y")` instead.
 geom_errorbarh <- function(..., orientation = "y") {
   deprecate_soft0(
-    "3.5.2", "geom_errobarh()", "geom_errorbar(orientation = \"y\")",
+    "4.0.0", "geom_errobarh()", "geom_errorbar(orientation = \"y\")",
     id = "no-more-errorbarh"
   )
   geom_errorbar(..., orientation = orientation)

R/geom-label.R

@@ -28,7 +28,7 @@ geom_label <- function(mapping = NULL, data = NULL,
 
   extra_args <- list2(...)
   if (lifecycle::is_present(label.size)) {
-    deprecate_warn0("3.5.0", "geom_label(label.size)", "geom_label(linewidth)")
+    deprecate_soft0("3.5.0", "geom_label(label.size)", "geom_label(linewidth)")
     extra_args$linewidth <- extra_args$linewidth %||% label.size
   }
 

R/geom-path.R

@@ -6,7 +6,7 @@ GeomPath <- ggproto("GeomPath", Geom,
   required_aes = c("x", "y"),
 
   default_aes = aes(
-    colour = from_theme(ink),
+    colour = from_theme(colour %||% ink),
     linewidth = from_theme(linewidth),
     linetype = from_theme(linetype),
     alpha = NA

R/geom-pointrange.R

@@ -16,7 +16,7 @@ GeomPointrange <- ggproto("GeomPointrange", Geom,
 
   setup_params = function(data, params) {
     if (lifecycle::is_present(params$fatten %||% deprecated())) {
-      deprecate_soft0("3.6.0", "geom_pointrange(fatten)", I("the `size` aesthetic"))
+      deprecate_soft0("4.0.0", "geom_pointrange(fatten)", I("the `size` aesthetic"))
     } else {
       # For backward compatibility reasons
       params$fatten <- 4

R/geom-violin.R

@@ -111,7 +111,7 @@ geom_violin <- function(mapping = NULL, data = NULL,
   extra <- list()
   if (lifecycle::is_present(draw_quantiles)) {
     deprecate_soft0(
-      "3.6.0",
+      "4.0.0",
       what = "geom_violin(draw_quantiles)",
       with = "geom_violin(quantiles.linetype)"
     )

R/guide-colorsteps.R

@@ -194,7 +194,7 @@ GuideColoursteps <- ggproto(
     params$title <- scale$make_title(params$title, scale$name, title)
 
     limits <- c(params$decor$min[1], params$decor$max[nrow(params$decor)])
-    if (params$reverse) {
+    if (isTRUE(params$reverse)) {
       limits <- rev(limits)
     }
     params$key$.value <- rescale(params$key$.value, from = limits)

R/guides-.R

@@ -274,7 +274,7 @@ Guides <- ggproto(
   #
   # The resulting guide is then drawn in ggplot_gtable
 
-  build = function(self, scales, layers, labels, layer_data, theme = theme()) {
+  build = function(self, scales, layers, labels, layer_data, theme = NULL) {
 
     # Empty guides list
     custom <- self$get_custom()
@@ -300,6 +300,7 @@ Guides <- ggproto(
     }
 
     # Merge and process layers
+    theme <- theme %||% theme()
     guides$merge()
     guides$process_layers(layers, layer_data, theme)
     if (length(guides$guides) == 0) {

R/labels.R

@@ -78,7 +78,8 @@ setup_plot_labels <- function(plot, layers, data) {
   # `geom_function()`. We can display these labels anyway, so we include them.
   plot_labels  <- plot@labels
   known_labels <- c(names(labels), fn_fmls_names(labs), "x", "y")
-  extra_labels <- setdiff(names(plot_labels), known_labels)
+  extra_labels <- names(plot_labels)[lengths(plot_labels) > 0]
+  extra_labels <- setdiff(extra_labels, known_labels)
 
   if (length(extra_labels) > 0) {
 
@@ -92,7 +93,7 @@ setup_plot_labels <- function(plot, layers, data) {
     extra_labels <- paste0("{.field ", extra_labels, "} : ", warn_labels)
     names(extra_labels) <- rep("*", length(extra_labels))
 
-    cli::cli_warn(c(
+    cli::cli_inform(c(
       "Ignoring unknown labels:",
       extra_labels
     ))

R/layer-sf.R

@@ -78,7 +78,12 @@ LayerSf <- ggproto("LayerSf", Layer,
 geom_column <- function(data) {
   w <- which(vapply(data, inherits, TRUE, what = "sfc"))
   if (length(w) == 0) {
-    "geometry" # avoids breaks when objects without geometry list-column are examined
+    if (!is.character(data[["geometry"]])) {
+      "geometry" # avoids breaks when objects without geometry list-column are examined
+    } else {
+      # Avoids a rare case where computed_geom_params$legend is present but there is no actual geometry column
+      ""
+    }
   } else {
     # this may not be best in case more than one geometry list-column is present:
     if (length(w) > 1)

R/layer.R

@@ -941,7 +941,7 @@ set_draw_key <- function(geom, draw_key = NULL) {
   }
   draw_key <- match.fun(draw_key)
 
-  ggproto("", geom, draw_key = draw_key)
+  ggproto(NULL, geom, draw_key = draw_key)
 }
 
 cleanup_mismatched_data <- function(data, n, fun) {

R/plot-build.R

@@ -317,13 +317,13 @@ S7::method(gtable_ggplot, class_ggplot_built) <- function(data) {
 # TODO: the S3 generic should be phased out once S7 is adopted more widely
 #' @rdname gtable_ggplot
 #' @export
-ggplot_gtable <- function(plot) {
+ggplot_gtable <- function(data) {
   UseMethod("ggplot_gtable")
 }
 
 #' @export
-ggplot_gtable.default <- function(plot) {
-  gtable_ggplot(plot)
+ggplot_gtable.default <- function(data) {
+  gtable_ggplot(data)
 }
 
 #' Generate a ggplot2 plot grob.

R/plot-construction.R

@@ -24,6 +24,7 @@
 #' @param e1 An object of class [ggplot()] or a [theme()].
 #' @param e2 A plot component, as described below.
 #' @seealso [theme()]
+#' @aliases +.gg
 #' @rdname gg-add
 #' @export
 #' @examples
@@ -135,6 +136,10 @@ S7::method(update_ggplot, list(S7::class_any, class_ggplot)) <-
   function(object, plot, object_name, ...) {
 
     if (!S7::S7_inherits(object) && inherits(object, "theme")) {
+      # This is a contingency for patchwork/#438
+      if (length(object) == 0) {
+        return(plot)
+      }
       # For backward compatibility, we try to cast old S3 themes (lists with
       # the class 'theme') to proper themes. People *should* use `theme()`,
       # so we should be pushy here.

R/plot.R

@@ -276,13 +276,14 @@ S7::method(plot, class_ggplot) <- `print.ggplot2::ggplot`
 `[[<-.ggplot2::gg` <- `$<-.ggplot2::gg`
 
 #' @importFrom S7 convert
-S7::method(convert, list(from = class_ggplot, to = S7::class_list)) <-
-  function(from, to) {
-    S7::props(from)
-  }
-
 # S7 currently attaches the S3 method to the calling environment which gives `ggplot2:::as.list`
 # Wrap in `local()` to provide a temp environment which throws away the attachment
 local({
-  S7::method(as.list, class_ggplot) <- function(x, ...) convert(x, S7::class_list)
+  S7::method(convert, list(from = class_ggplot, to = S7::class_list)) <-
+    function(from, to) {
+      S7::props(from)
+    }
+
+  S7::method(as.list, class_ggplot) <-
+    function(x, ...) convert(x, S7::class_list)
 })

R/position-dodge.R

@@ -152,7 +152,7 @@ PositionDodge <- ggproto("PositionDodge", Position,
     data$order <- xtfrm( # xtfrm makes anything 'sortable'
       data$order %||% ave(data$group, data$x, data$PANEL, FUN = match_sorted)
     )
-    if (params$reverse) {
+    if (isTRUE(params$reverse)) {
       data$order <- -data$order
     }
     if (is.null(params$n)) { # preserve = "total"

R/position-stack.R

@@ -154,7 +154,7 @@ PositionStack <- ggproto("PositionStack", Position,
     flipped_aes <- has_flipped_aes(data)
     data <- flip_data(data, flipped_aes)
     var <- self$var %||% stack_var(data)
-    if (!vec_duplicate_any(data$x)) {
+    if (!vec_duplicate_any(data$x)  && !isTRUE(self$fill)) {
       # We skip stacking when all data have different x positions so that
       # there is nothing to stack
       var <- NULL

R/scale-.R

@@ -104,7 +104,7 @@
 continuous_scale <- function(aesthetics, scale_name = deprecated(), palette, name = waiver(),
                              breaks = waiver(), minor_breaks = waiver(), n.breaks = NULL,
                              labels = waiver(), limits = NULL, rescaler = rescale,
-                             oob = censor, expand = waiver(), na.value = NA_real_,
+                             oob = censor, expand = waiver(), na.value = NA,
                              transform = "identity", trans = deprecated(),
                              guide = "legend", position = "left",
                              call = caller_call(),
@@ -1331,7 +1331,7 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale,
       vec_slice(pal, match(as.character(x), limits, nomatch = vec_size(pal)))
 
     if (!is.na(na_value)) {
-      vec_slice(pal_match, is.na(x)) <- na_value
+      vec_slice(pal_match, vec_detect_missing(x)) <- na_value
     }
     pal_match
   },

R/stat-summary-2d.R

@@ -15,7 +15,7 @@ StatSummary2d <- ggproto(
       params$drop <- !identical(params$drop, "none")
     }
 
-    params <- fix_bin_params(params, fun = snake_class(self), version = "3.5.2")
+    params <- fix_bin_params(params, fun = snake_class(self), version = "4.0.0")
     vars <- c("origin", "binwidth", "breaks", "center", "boundary")
     params[vars] <- lapply(params[vars], dual_param, default = NULL)
     params$closed <- dual_param(params$closed, list(x = "right", y = "right"))

R/stat-summary-bin.R

@@ -108,6 +108,13 @@ make_summary_fun <- function(fun.data, fun, fun.max, fun.min, fun.args) {
   force(fun.min)
   force(fun.args)
 
+  as_function <- function(x) {
+    if (is.character(x)) {
+      x <- match.fun(x)
+    }
+    rlang::as_function(x)
+  }
+
   if (!is.null(fun.data)) {
     # Function that takes complete data frame as input
     fun.data <- as_function(fun.data)

R/stat-ydensity.R

@@ -12,7 +12,7 @@ StatYdensity <- ggproto(
 
     if (!is.null(params$draw_quantiles)) {
       deprecate_soft0(
-        "3.6.0",
+        "4.0.0",
         what = "stat_ydensity(draw_quantiles)",
         with = "stat_ydensity(quantiles)"
       )