feat!: Update geoms to more closely match ggplot2 v3.5.1

* Internal geom code has been updated to more closely match ggplot2 v3.5.1 equivalents when viewed with vimdiff algorithms * Geoms now more consistently expose the `lineend` and `linejoin` parameters. This matches a similar upstream change in ggplot2 3.4.0. * `geom_area_pattern()` and `geom_ribbon_pattern()` now accept `outline.type = "lower"` and `outline.type = "full"`. `geom_density_pattern()` now exposes the `outline.type` parameter. * `geom_boxplot_pattern()` now accept the `outliers` and `staplewidth` parameters. The `outliers` and `staplewidth` parameters were added to `geom_boxplot()` in ggplot2 3.5.0. * `geom_sf_pattern()` now accepts the `arrow` parameter. The `arrow` parameter was added to `geom_sf()` in ggplot2 3.5.0. * `geom_violin_pattern()` now accepts the `bounds` parameter. The `bounds` parameter was added to `geom_violin()` in ggplot2 3.5.0. BREAKING CHANGES: * `outline.type = "legacy"` has been removed in `geom_area_pattern()` and `geom_ribbon_pattern()`. `outline.type = "legacy"` was deprecated with ggpattern 0.1.0 (2020-04-01). closes #94
trevorld · Apr 24, 2024 · 339838d · 339838d
1 parent 6231612
commit 339838d
Show file tree

Hide file tree

Showing 66 changed files with 1,026 additions and 1,325 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: ggpattern
 Type: Package
 Title: 'ggplot2' Pattern Geoms
-Version: 1.1.0-7
+Version: 1.1.0-8
 Authors@R: c(person("Mike", "FC", role = "aut"),
              person("Trevor L.", "Davis", role = c("aut", "cre"),
                     email = "[email protected]",
@@ -15,13 +15,15 @@ Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.1
 Imports:
-    ggplot2 (>= 3.5.0),
+    cli,
+    ggplot2 (>= 3.5.1),
     glue,
     grid,
     gridpattern (>= 1.2.0-4),
     lifecycle,
-    rlang,
+    rlang (>= 1.1.3),
     scales,
+    vctrs
 Suggests: 
     ambient,
     dplyr,
@@ -47,7 +49,6 @@ Collate:
     'aaa-ggplot2-scale-manual.R'
     'aaa-ggplot2-utilities-grid.R'
     'aaa-ggplot2-utilities.R'
-    'aab-utils.R'
     'geom-.R'
     'geom-rect.R'
     'geom-bar.R'

diff --git a/NAMESPACE b/NAMESPACE
@@ -198,10 +198,12 @@ import(glue)
 import(grid)
 import(rlang)
 import(scales)
+import(vctrs)
 importFrom(grDevices,col2rgb)
 importFrom(grDevices,dev.off)
 importFrom(grDevices,png)
 importFrom(grDevices,rgb)
+importFrom(lifecycle,deprecate_soft)
 importFrom(lifecycle,deprecated)
 importFrom(stats,setNames)
 importFrom(utils,head)

diff --git a/NEWS.md b/NEWS.md
@@ -7,6 +7,10 @@
 * The `draw_key_polygon_pattern()` called by `geom_sf_pattern()` is now passed in its
   actual aspect ratio (instead of 1).
   This may cause your legends to `geom_sf_pattern()` to look different.
+* `outline.type = "legacy"` has been removed in
+  `geom_area_pattern()` and `geom_ribbon_pattern()`.
+  `outline.type = "legacy"` was deprecated with ggpattern 0.1.0 (2020-04-01).
+  Use `outline.type = "full"` instead.
 
 ## Deprecated features
 
@@ -15,17 +19,27 @@
 
 ## New features
 
-* `geom_bar_pattern()` and `geom_col_pattern()` now accept argument `just`.
-  The `just` argument was added to `ggplot2::geom_bar()` and `ggplot2::geom_col()` with ggplot2 3.4.0.
-* `geom_bin_2d_pattern()` is now an alias for `geom_bin2d_pattern()`.
-  This matches `{ggplot2}` which has both `geom_bin_2d()` and `geom_bin2d()`.
+* Geoms now more consistently expose the `lineend` and `linejoin` parameters (#94).
+  This matches a similar upstream change in ggplot2 3.4.0.
+* `geom_area_pattern()` and `geom_ribbon_pattern()` now accept `outline.type = "lower"` and `outline.type = "full"`.
+  `geom_density_pattern()` now exposes the `outline.type` parameter.
+* `geom_bar_pattern()` and `geom_col_pattern()` now accept parameter `just`.
+  The `just` parameter was added to `ggplot2::geom_bar()` and `ggplot2::geom_col()` with ggplot2 3.4.0.
+* `geom_boxplot_pattern()` now accept the `outliers` and `staplewidth` parameters.
+  The `outliers` and `staplewidth` parameters were added to `geom_boxplot()` in ggplot2 3.5.0.
+* `geom_sf_pattern()` now accepts the `arrow` parameter.
+  The `arrow` parameter was added to `geom_sf()` in ggplot2 3.5.0.
+* `geom_violin_pattern()` now accepts the `bounds` parameter.
+  The `bounds` parameter was added to `geom_violin()` in ggplot2 3.5.0.
 * Each pattern aesthetic may now be a list of vectors with each list element
   providing that aesthetic for a different pattern (#100).
   Most builtin `{gridpattern}` "geometry" patterns support multiple fill colors etc. which previously we could only access in `{ggpattern}` via custom patterns.
 * The `fill` and `pattern_fill` aesthetics may now be (a list of) gradient/pattern fills
   (in addition to color strings) (#112).
   Note using gradient/pattern fills will require R (>= 4.2) and a graphics device with support for the gradient/pattern fill feature.
   Use of just color fills should continue to work on a wider variety of R versions and graphics devices.
+* `geom_bin_2d_pattern()` is now an alias for `geom_bin2d_pattern()`.
+  This matches `{ggplot2}` which has both `geom_bin_2d()` and `geom_bin2d()`.
 
 ## Bug fixes and minor improvements
 

diff --git a/R/aaa-ggplot2-compat-plyr.R b/R/aaa-ggplot2-compat-plyr.R
@@ -1,7 +1,6 @@
+# This file was copied (mostly untouched) from ggplot2
 
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-# This file was copied (mostly untouched) from ggplot2 v3.3.0.9000
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+defaults <- function(x, y) c(x, y[setdiff(names(y), names(x))])
 
 #' Rename elements in a list, data.frame or vector
 #'

diff --git a/R/aaa-ggplot2-performance.R b/R/aaa-ggplot2-performance.R
@@ -1,68 +1,5 @@
-
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-# This file was copied (mostly untouched) from ggplot2 v3.3.0.9000
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-# Fast data.frame constructor and indexing
-# No checking, recycling etc. unless asked for
-new_data_frame <- function(x = list(), n = NULL) {
-  if (length(x) != 0 && is.null(names(x))) {
-    abort("Elements must be named")
-  }
-  lengths <- vapply(x, length, integer(1))
-  if (is.null(n)) {
-    n <- if (length(x) == 0 || min(lengths) == 0) 0 else max(lengths)
-  }
-  for (i in seq_along(x)) {
-    if (lengths[i] == n) next
-    if (lengths[i] != 1) {
-      abort("Elements must equal the number of rows or 1")
-    }
-    x[[i]] <- rep(x[[i]], n)
-  }
-
-  class(x) <- "data.frame"
-
-  attr(x, "row.names") <- .set_row_names(n)
-  x
-}
-
-data_frame <- function(...) {
-  new_data_frame(list(...))
-}
-
-# data.frame <- function(...) {
-#   abort(glue("
-#     Please use `data_frame()` or `new_data_frame()` instead of `data.frame()` for better performance.
-#     See the vignette 'ggplot2 internal programming guidelines' for details.
-#   "))
-# }
-
-split_matrix <- function(x, col_names = colnames(x)) {
-  force(col_names)
-  x <- lapply(seq_len(ncol(x)), function(i) x[, i])
-  if (!is.null(col_names)) names(x) <- col_names
-  x
-}
-
-mat_2_df <- function(x, col_names = colnames(x)) {
-  new_data_frame(split_matrix(x, col_names))
-}
-
-df_col <- function(x, name) .subset2(x, name)
-
-df_rows <- function(x, i) {
-  new_data_frame(lapply(x, `[`, i = i))
-}
-
 # More performant modifyList without recursion
 modify_list <- function(old, new) {
   for (i in names(new)) old[[i]] <- new[[i]]
   old
 }
-# modifyList <- function(...) {
-#   abort(glue("
-#     Please use `modify_list()` instead of `modifyList()` for better performance.
-#     See the vignette 'ggplot2 internal programming guidelines' for details.
-#   "))
-# }
diff --git a/R/aaa-ggplot2-utilities.R b/R/aaa-ggplot2-utilities.R
@@ -1,41 +1,3 @@
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-# This file was copied (mostly untouched) from ggplot2 v3.3.0.9000
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-"%||%" <- function(a, b) {
-  if (!is.null(a)) a else b
-}
-
-# Check required aesthetics are present
-# This is used by geoms and stats to give a more helpful error message
-# when required aesthetics are missing.
-#
-# @param character vector of required aesthetics
-# @param character vector of present aesthetics
-# @param name of object for error message
-# @keyword internal
-check_required_aesthetics <- function(required, present, name) {
-  if (is.null(required)) return()
-
-  required <- strsplit(required, "|", fixed = TRUE)
-  if (any(vapply(required, length, integer(1)) > 1)) {
-    required <- lapply(required, rep_len, 2)
-    required <- list(
-      vapply(required, `[`, character(1), 1),
-      vapply(required, `[`, character(1), 2)
-    )
-  } else {
-    required <- list(unlist(required))
-  }
-  missing_aes <- lapply(required, setdiff, present)
-  if (any(vapply(missing_aes, length, integer(1)) == 0)) return()
-
-  abort(glue(
-    "{name} requires the following missing aesthetics: ",
-    glue_collapse(lapply(missing_aes, glue_collapse, sep = ", ", last = " and "), sep = " or ")
-  ))
-}
-
 # Returns a logical vector of same length as nrow(x). If all data on a row
 # is finite (not NA, NaN, Inf, or -Inf) return TRUE; otherwise FALSE.
 cases <- function(x, fun) {
@@ -78,11 +40,8 @@ binned_pal <- function(palette) {
   }
 }
 
-is.formula <- function(x) inherits(x, "formula")
-
-warning_wrap <- function(...) {
-  msg <- paste(..., collapse = "", sep = "")
-  wrapped <- strwrap(msg, width = getOption("width") - 2)
-  warn(glue_collapse(wrapped, "\n", last = "\n"))
-}
+# Wrapping vctrs data_frame constructor with no name repair
+data_frame0 <- function(...) data_frame(..., .name_repair = "minimal")
 
+# Wrapping unique0() to accept NULL
+unique0 <- function(x, ...) if (is.null(x)) x else vec_unique(x, ...)
diff --git a/R/aab-utils.R b/R/aab-utils.R
diff --git a/R/geom-.R b/R/geom-.R
@@ -1,9 +1,6 @@
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-# This is the list of all pattern aesthetics.
+# * This is the list of all pattern aesthetics.
 # * List is shared across every geom
 # * Not all aesthetics are used by all patterns.
-#   is only used by the 'point' pattern.
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 pattern_aesthetics <- aes(
   pattern                  = 'stripe',
   pattern_type             = NA,
@@ -46,60 +43,6 @@ pattern_aesthetics <- aes(
   pattern_res              = getOption("ggpattern_res", NA)
 )
 
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-# Utils for debugging viewports
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-print_vp_tree <- function() {
-  startport <- grid::current.viewport()$name
-  on.exit({
-    if (startport != 'ROOT') {
-      grid::seekViewport(startport)
-    }
-  })
-
-  # myvp <<- grid::current.viewport()
-
-  while (TRUE) {
-    vp <- grid::current.viewport()
-    message(
-      "-------------- ",
-      sprintf("%20s", vp$name),
-      "  ",
-      round(get_aspect_ratio(), 3)
-    )
-    tmat <- grid::current.transform()
-    print(tmat)
-    message(
-      round(tmat[3, 1]/tmat[3, 2], 3), "  ",
-      round(tmat[3, 2]/tmat[3, 1], 3)
-    )
-
-    if (vp$name == 'layout') {
-      # myll <<- grid::current.viewport()
-    }
-
-
-    if (vp$name == 'ROOT') {
-      message("ROOT. done")
-      break
-    }
-
-    grid::upViewport()
-  }
-}
-
-
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-# Utils for debugging viewports
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-verboseGrob <- function(name = "Viewport Tree") {
-  delayGrob({
-    message("=================== ", name, " ===================")
-    print_vp_tree()
-    nullGrob()
-  }, list=list(name = name))
-}
-
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 #' Create the patterned area to be used in the legend key
 #' @inheritParams  draw_key_polygon_pattern
@@ -377,3 +320,11 @@ draw_key_crossbar_pattern <- function(data, params, size, aspect_ratio = get_asp
     key_grob_line
   )
 }
+
+check_linewidth <- function(data, name) {
+  if (is.null(data$linewidth) && !is.null(data$size)) {
+    deprecate_soft("1.0.1", I(paste0("Using the `size` aesthetic with ", name)), I("the `linewidth` aesthetic"))
+    data$linewidth <- data$size
+  }
+  data
+}
diff --git a/R/geom-bar.R b/R/geom-bar.R
@@ -123,7 +123,6 @@ geom_bar_pattern <- function(mapping = NULL, data = NULL,
                              orientation = NA,
                              show.legend = NA,
                              inherit.aes = TRUE) {
-
   layer(
     data = data,
     mapping = mapping,
@@ -132,7 +131,7 @@ geom_bar_pattern <- function(mapping = NULL, data = NULL,
     position = position,
     show.legend = show.legend,
     inherit.aes = inherit.aes,
-    params = list(
+    params = list2(
       just = just,
       width = width,
       na.rm = na.rm,
@@ -142,20 +141,21 @@ geom_bar_pattern <- function(mapping = NULL, data = NULL,
   )
 }
 
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 #' Geom ggproto objects
 #'
 #' Geom ggproto objects that could be extended to create a new geom.
 #'
 #' @seealso [ggplot2::Geom]
 #'
 #' @name ggpattern-ggproto
+NULL
+
+#' @rdname ggpattern-ggproto
 #' @format NULL
+#' @usage NULL
 #' @export
 #' @include geom-rect.R
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-GeomBarPattern <- ggproto(
-  "GeomBarPattern", GeomRectPattern,
+GeomBarPattern <- ggproto( "GeomBarPattern", GeomRectPattern,
   required_aes = c("x", "y"),
 
   # These aes columns are created by setup_data(). They need to be listed here so
@@ -174,7 +174,10 @@ GeomBarPattern <- ggproto(
     data$flipped_aes <- params$flipped_aes
     data <- flip_data(data, params$flipped_aes)
     data$width <- data$width %||%
-      params$width %||% (resolution(data$x, FALSE) * 0.9)
+      params$width %||% (min(vapply(
+        split(data$x, data$PANEL, drop = TRUE),
+        resolution, numeric(1), zero = FALSE
+      )) * 0.9)
     data$just <- params$just %||% 0.5
     data <- transform(data,
                       ymin = pmin(y, 0), ymax = pmax(y, 0),
@@ -184,10 +187,16 @@ GeomBarPattern <- ggproto(
     flip_data(data, params$flipped_aes)
   },
 
-  draw_panel = function(self, data, panel_params, coord,
-                        width = NULL, flipped_aes = FALSE) {
+  draw_panel = function(self, data, panel_params, coord, lineend = "butt",
+                        linejoin = "mitre", width = NULL, flipped_aes = FALSE) {
     # Hack to ensure that width is detected as a parameter
-    ggproto_parent(GeomRectPattern, self)$draw_panel(data, panel_params, coord)
+    ggproto_parent(GeomRectPattern, self)$draw_panel(
+      data,
+      panel_params,
+      coord,
+      lineend = lineend,
+      linejoin = linejoin
+    )
   },
   rename_size = TRUE
 )