Barebones support for <GridPattern> fills. (#5299)

* Write pattern utilities

* Intercept non-list patterns

* Support pattern fills in geoms

* Support pattern fills in keys

* Note that `geom_raster()` cannot use pattern fills

* More informative call in error message

* Write tests

* Document

* Some version protections

* Use device checker

* Set white alpha mask

* Clarify error message

* deal with unavailable functions/arguments

* typo

* Also handle unlisted pattern

* Invert viewport backport

* `geom_raster()` throws error when fill is pattern

* device check warns instead of aborts

* reimplement `pattern_alpha` as S3 generic + methods

* accept new snapshot

* Add news bullet

Author: teunbrand

DESCRIPTION

@@ -275,6 +275,7 @@ Collate:
     'utilities-grid.R'
     'utilities-help.R'
     'utilities-matrix.R'
+    'utilities-patterns.R'
     'utilities-resolution.R'
     'utilities-tidy-eval.R'
     'zxx.R'

NAMESPACE

@@ -95,6 +95,10 @@ S3method(makeContext,dotstackGrob)
 S3method(merge_element,default)
 S3method(merge_element,element)
 S3method(merge_element,element_blank)
+S3method(pattern_alpha,GridPattern)
+S3method(pattern_alpha,GridTilingPattern)
+S3method(pattern_alpha,default)
+S3method(pattern_alpha,list)
 S3method(plot,ggplot)
 S3method(predictdf,default)
 S3method(predictdf,glm)
@@ -354,6 +358,7 @@ export(expr)
 export(facet_grid)
 export(facet_null)
 export(facet_wrap)
+export(fill_alpha)
 export(find_panel)
 export(flip_data)
 export(flipped_names)
@@ -476,6 +481,7 @@ export(new_guide)
 export(old_guide)
 export(panel_cols)
 export(panel_rows)
+export(pattern_alpha)
 export(position_dodge)
 export(position_dodge2)
 export(position_fill)

NEWS.md

@@ -1,5 +1,10 @@
 # ggplot2 (development version)
 
+* The `fill` aesthetic in many geoms now accepts grid's patterns and gradients.
+  For developers of layer extensions, this feature can be enabled by switching 
+  from `fill = alpha(fill, alpha)` to `fill = fill_alpha(fill, alpha)` when 
+  providing fills to `grid::gpar()` (@teunbrand, #3997).
+
 * The plot's title, subtitle and caption now obey horizontal text margins
   (#5533).
 

R/backports.R

@@ -22,3 +22,26 @@ if (getRversion() < "3.5") {
   isFALSE <- function(x) is.logical(x) && length(x) == 1L && !is.na(x) && !x
   isTRUE  <- function(x) is.logical(x) && length(x) == 1L && !is.na(x) &&  x
 }
+
+version_unavailable <- function(...) {
+  fun <- as_label(current_call()[[1]])
+  cli::cli_abort("{.fn {fun}} is not available in R version {getRversion()}.")
+}
+
+# Ignore mask argument if on lower R version (<= 4.1)
+viewport <- function(..., mask) grid::viewport(...)
+pattern  <- version_unavailable
+as.mask  <- version_unavailable
+on_load({
+  if ("mask" %in% fn_fmls_names(grid::viewport)) {
+    viewport <- grid::viewport
+  }
+  # Replace version unavailable functions if found
+  if ("pattern" %in% getNamespaceExports("grid")) {
+    pattern <- grid::pattern
+  }
+  if ("as.mask" %in% getNamespaceExports("grid")) {
+    as.mask <- grid::as.mask
+  }
+})
+

R/geom-.R

@@ -126,6 +126,10 @@ Geom <- ggproto("Geom",
       deprecate_soft0("3.4.0", I("Using the `size` aesthetic in this geom"), I("`linewidth` in the `default_aes` field and elsewhere"))
       default_aes$linewidth <- default_aes$size
     }
+    if (is_pattern(params$fill)) {
+      params$fill <- list(params$fill)
+    }
+
     # Fill in missing aesthetics with their defaults
     missing_aes <- setdiff(names(default_aes), names(data))
 

R/geom-boxplot.R

@@ -239,7 +239,7 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom,
       colour = data$colour,
       linewidth = data$linewidth,
       linetype = data$linetype,
-      fill = alpha(data$fill, data$alpha),
+      fill = fill_alpha(data$fill, data$alpha),
       group = data$group
     )
 

R/geom-dotplot.R

@@ -294,7 +294,7 @@ GeomDotplot <- ggproto("GeomDotplot", Geom,
                   stackposition = tdata$stackpos, stackdir = stackdir, stackratio = stackratio,
                   default.units = "npc",
                   gp = gpar(col = alpha(tdata$colour, tdata$alpha),
-                            fill = alpha(tdata$fill, tdata$alpha),
+                            fill = fill_alpha(tdata$fill, tdata$alpha),
                             lwd = tdata$stroke, lty = tdata$linetype,
                             lineend = lineend))
     )

R/geom-hex.R

@@ -90,7 +90,7 @@ GeomHex <- ggproto("GeomHex", Geom,
       coords$x, coords$y,
       gp = gpar(
         col = data$colour,
-        fill = alpha(data$fill, data$alpha),
+        fill = fill_alpha(data$fill, data$alpha),
         lwd = data$linewidth * .pt,
         lty = data$linetype,
         lineend = lineend,

R/geom-label.R

@@ -103,7 +103,7 @@ GeomLabel <- ggproto("GeomLabel", Geom,
         ),
         rect.gp = gpar(
           col = if (isTRUE(all.equal(label.size, 0))) NA else row$colour,
-          fill = alpha(row$fill, row$alpha),
+          fill = fill_alpha(row$fill, row$alpha),
           lwd = label.size * .pt
         )
       )

R/geom-map.R

@@ -146,7 +146,7 @@ GeomMap <- ggproto("GeomMap", GeomPolygon,
     polygonGrob(coords$x, coords$y, default.units = "native", id = grob_id,
       gp = gpar(
         col = data$colour,
-        fill = alpha(data$fill, data$alpha),
+        fill = fill_alpha(data$fill, data$alpha),
         lwd = data$linewidth * .pt,
         lineend = lineend,
         linejoin = linejoin,