Polishes triggered by revdep failures

R/coord-radial.R

@@ -136,7 +136,7 @@
   }
   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 @@
 #' @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-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-errorbar.R

@@ -69,7 +69,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 +87,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-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 @@
   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 @@
 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/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.R

@@ -280,6 +280,7 @@ S7::method(convert, list(from = class_ggplot, to = S7::class_list)) <-
   function(from, to) {
     S7::props(from)
   }
+rm(`convert`)
 
 S7::method(as.list, class_ggplot) <- function(x, ...) convert(x, S7::class_list)
 rm(`as.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

@@ -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)"
       )

R/theme.R

@@ -518,9 +518,9 @@
     )
     if (is.null(elements[["legend.title"]])) {
       elements$legend.title <- element_text(hjust = elements$legend.title.align)
-    } else {
-      elements$legend.title$hjust <- elements$legend.title$hjust %||%
-        elements$legend.title.align
+    } else if (!is_theme_element(elements$legend.title, "blank")) {
+      elements$legend.title$hjust <-
+        try_prop(elements$legend.title, "hjust", elements$legend.title.align)
     }
     elements$legend.title.align <- NULL
   }
@@ -531,9 +531,9 @@
     )
     if (is.null(elements[["legend.text"]])) {
       elements$legend.text <- element_text(hjust = elements$legend.text.align)
-    } else {
-      elements$legend.text$hjust <- elements$legend.text$hjust %||%
-        elements$legend.text.align
+    } else if (!is_theme_element(elements$legend.text, "blank")) {
+      elements$legend.text$hjust <-
+        try_prop(elements$legend.text, "hjust", elements$legend.text.align)
     }
     elements$legend.text.align <- NULL
   }
@@ -980,7 +980,7 @@
   # Backward compatbility
   # TODO: deprecate next release cycle
   is_old_element <- !S7::S7_inherits(e1) && inherits(e1, "element")
-  if (is_old_element && is_theme_element(e2)) {
+  if (is_old_element && (is_theme_element(e2) || inherits(e2, "element"))) {
     return(combine_s3_elements(e1, e2))
   }
 
@@ -999,22 +999,24 @@
     }
   }
 
+  parent_props <- if (S7::S7_inherits(e2)) S7::props(e2) else unclass(e2)
+
   # If e1 has any NULL properties, inherit them from e2
   n <- S7::prop_names(e1)[lengths(S7::props(e1)) == 0]
-  S7::props(e1)[n] <- S7::props(e2)[n]
+  S7::props(e1)[n] <- parent_props[n]
 
   # Calculate relative sizes
   if (is_rel(try_prop(e1, "size"))) {
-    e1@size <- e2@size * unclass(e1@size)
+    e1@size <- parent_props$size * unclass(e1@size)
   }
 
   # Calculate relative linewidth
   if (is_rel(try_prop(e1, "linewidth"))) {
-    e1@linewidth <- e2@linewidth * unclass(e1@linewidth)
+    e1@linewidth <- parent_props$linewidth * unclass(e1@linewidth)
   }
 
   if (is_theme_element(e1, "text")) {
-    e1@margin <- combine_elements(e1@margin, e2@margin)
+    e1@margin <- combine_elements(e1@margin, parent_props$margin)
   }
 
   # If e2 is 'richer' than e1, fill e2 with e1 parameters

tests/testthat/_snaps/labels.md

@@ -14,10 +14,13 @@
 
 # warnings are thrown for unknown labels
 
-    Ignoring unknown labels:
-    * foo : "i don't exist"
-    * bar : <function>
-    * qux : "expression(me * neither)"
+    Code
+      p <- ggplot_build(p)
+    Message
+      Ignoring unknown labels:
+      * foo : "i don't exist"
+      * bar : <function>
+      * qux : "expression(me * neither)"
 
 # plot.tag.position rejects invalid input
 

tests/testthat/test-labels.R

@@ -117,7 +117,7 @@ test_that("warnings are thrown for unknown labels", {
       bar = function(x) "i don't exist either",
       qux = expression(me * neither)
     )
-  expect_snapshot_warning(ggplot_build(p))
+  expect_snapshot(p <- ggplot_build(p))
 })
 
 test_that("plot.tag.position rejects invalid input", {

tests/testthat/test-position-stack.R

@@ -64,6 +64,12 @@ test_that("position_stack() can stack correctly when ymax is NA", {
   expect_equal(get_layer_data(p)$y, c(1, 2))
 })
 
+test_that("position_fill() handles one group per position case", {
+  df <- data_frame0(x = c("A", "B", "C"), y = 1:3)
+  p <- ggplot(df, aes(x, y)) + geom_col(position = "fill")
+  expect_equal(get_layer_data(p)$y, c(1, 1, 1))
+})
+
 # Visual tests ------------------------------------------------------------
 
 test_that("Stacking produces the expected output", {