Barebones support for <GridPattern> fills.

DESCRIPTION

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

NAMESPACE

@@ -348,6 +348,7 @@ export(expr)
 export(facet_grid)
 export(facet_null)
 export(facet_wrap)
+export(fill_alpha)
 export(find_panel)
 export(flip_data)
 export(flipped_names)

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,

R/geom-point.R

@@ -131,7 +131,7 @@ GeomPoint <- ggproto("GeomPoint", Geom,
         pch = coords$shape,
         gp = gpar(
           col = alpha(coords$colour, coords$alpha),
-          fill = alpha(coords$fill, coords$alpha),
+          fill = fill_alpha(coords$fill, coords$alpha),
           # Stroke is added around the outside of the point
           fontsize = coords$size * .pt + stroke_size * .stroke / 2,
           lwd = coords$stroke * .stroke / 2

R/geom-polygon.R

@@ -132,7 +132,7 @@ GeomPolygon <- ggproto("GeomPolygon", Geom,
           id = munched$group,
           gp = gpar(
             col = first_rows$colour,
-            fill = alpha(first_rows$fill, first_rows$alpha),
+            fill = fill_alpha(first_rows$fill, first_rows$alpha),
             lwd = first_rows$linewidth * .pt,
             lty = first_rows$linetype,
             lineend = lineend,
@@ -163,7 +163,7 @@ GeomPolygon <- ggproto("GeomPolygon", Geom,
           rule = rule,
           gp = gpar(
             col = first_rows$colour,
-            fill = alpha(first_rows$fill, first_rows$alpha),
+            fill = fill_alpha(first_rows$fill, first_rows$alpha),
             lwd = first_rows$linewidth * .pt,
             lty = first_rows$linetype,
             lineend = lineend,

R/geom-rect.R

@@ -59,7 +59,7 @@ GeomRect <- ggproto("GeomRect", Geom,
         just = c("left", "top"),
         gp = gpar(
           col = coords$colour,
-          fill = alpha(coords$fill, coords$alpha),
+          fill = fill_alpha(coords$fill, coords$alpha),
           lwd = coords$linewidth * .pt,
           lty = coords$linetype,
           linejoin = linejoin,

R/geom-ribbon.R

@@ -183,7 +183,7 @@ GeomRibbon <- ggproto("GeomRibbon", Geom,
       munched_poly$x, munched_poly$y, id = munched_poly$id,
       default.units = "native",
       gp = gpar(
-        fill = alpha(aes$fill, aes$alpha),
+        fill = fill_alpha(aes$fill, aes$alpha),
         col = if (is_full_outline) aes$colour else NA,
         lwd = if (is_full_outline) aes$linewidth * .pt else 0,
         lty = if (is_full_outline) aes$linetype else 1,

R/geom-tile.R

@@ -5,7 +5,8 @@
 #' corners (`xmin`, `xmax`, `ymin` and `ymax`), while
 #' `geom_tile()` uses the center of the tile and its size (`x`,
 #' `y`, `width`, `height`). `geom_raster()` is a high
-#' performance special case for when all the tiles are the same size.
+#' performance special case for when all the tiles are the same size, and no
+#' pattern fills are applied.
 #'
 #' @eval rd_aesthetics("geom", "tile", "Note that `geom_raster()` ignores `colour`.")
 #' @inheritParams layer

R/legend-draw.R

@@ -38,7 +38,7 @@ draw_key_point <- function(data, params, size) {
     pch = data$shape,
     gp = gpar(
       col = alpha(data$colour %||% "black", data$alpha),
-      fill = alpha(data$fill %||% "black", data$alpha),
+      fill = fill_alpha(data$fill %||% "black", data$alpha),
       fontsize = (data$size %||% 1.5) * .pt + stroke_size * .stroke / 2,
       lwd = stroke_size * .stroke / 2
     )
@@ -63,7 +63,7 @@ draw_key_abline <- function(data, params, size) {
 draw_key_rect <- function(data, params, size) {
   rectGrob(gp = gpar(
     col = NA,
-    fill = alpha(data$fill %||% data$colour %||% "grey20", data$alpha),
+    fill = fill_alpha(data$fill %||% data$colour %||% "grey20", data$alpha),
     lty = data$linetype %||% 1
   ))
 }
@@ -81,7 +81,7 @@ draw_key_polygon <- function(data, params, size) {
     height = unit(1, "npc") - unit(lwd, "mm"),
     gp = gpar(
       col = data$colour %||% NA,
-      fill = alpha(data$fill %||% "grey20", data$alpha),
+      fill = fill_alpha(data$fill %||% "grey20", data$alpha),
       lty = data$linetype %||% 1,
       lwd = lwd * .pt,
       linejoin = params$linejoin %||% "mitre",
@@ -100,7 +100,7 @@ draw_key_blank <- function(data, params, size) {
 draw_key_boxplot <- function(data, params, size) {
   gp <- gpar(
     col = data$colour %||% "grey20",
-    fill = alpha(data$fill %||% "white", data$alpha),
+    fill = fill_alpha(data$fill %||% "white", data$alpha),
     lwd = (data$linewidth %||% 0.5) * .pt,
     lty = data$linetype %||% 1,
     lineend = params$lineend %||% "butt",
@@ -131,7 +131,7 @@ draw_key_boxplot <- function(data, params, size) {
 draw_key_crossbar <- function(data, params, size) {
   gp <- gpar(
     col = data$colour %||% "grey20",
-    fill = alpha(data$fill %||% "white", data$alpha),
+    fill = fill_alpha(data$fill %||% "white", data$alpha),
     lwd = (data$linewidth %||% 0.5) * .pt,
     lty = data$linetype %||% 1,
     lineend = params$lineend %||% "butt",
@@ -195,7 +195,7 @@ draw_key_dotplot <- function(data, params, size) {
     pch = 21,
     gp = gpar(
       col = alpha(data$colour %||% "black", data$alpha),
-      fill = alpha(data$fill %||% "black", data$alpha),
+      fill = fill_alpha(data$fill %||% "black", data$alpha),
       lty = data$linetype %||% 1,
       lineend = params$lineend %||% "butt"
     )

R/utilities-patterns.R

@@ -0,0 +1,100 @@
+
+#' Modify fill transparency
+#'
+#' This works much like [alpha()][scales::alpha] in that it modifies the
+#' transparency of fill colours. It differs in that `fill_alpha()` also attempts
+#' to set the transparency of `<GridPattern>` objects.
+#'
+#' @param fill A fill colour given as a `character` or `integer` vector, or as a
+#'   (list of) `<GridPattern>` object(s).
+#' @param alpha A transparency value between 0 (transparent) and 1 (opaque),
+#'   parallel to `fill`.
+#'
+#' @return A `character` vector of colours, or list of `<GridPattern>` objects.
+#' @export
+#' @keywords internal
+#'
+#' @examples
+#' # Typical colour input
+#' fill_alpha("red", 0.5)
+#'
+#' if (utils::packageVersion("grid") > "4.2") {
+#'   # Pattern input
+#'   fill_alpha(list(grid::linearGradient()), 0.5)
+#' }
+fill_alpha <- function(fill, alpha) {
+  if (!is.list(fill)) {
+    # Happy path for no patterns
+    return(alpha(fill, alpha))
+  }
+  if (is_pattern(fill) || any(vapply(fill, is_pattern, logical(1)))) {
+    check_device("patterns", action = "abort")
+    fill <- pattern_alpha(fill, alpha)
+    return(fill)
+  } else {
+    # We are either dealing with faulty fill specification, or we have a legend
+    # key that is trying to draw a single colour. It can be given that colour
+    # as a list due to patterns in other keys.
+    msg <- paste0(
+      "{.field fill} must be a vector of colours or list of ",
+      "{.cls GridPattern} objects."
+    )
+    # If single colour list, try applying `alpha()`
+    fill <- try_fetch(
+      Map(alpha, colour = fill, alpha = alpha),
+      error = function(cnd) {
+        cli::cli_abort(msg, call = expr(fill_alpha()))
+      }
+    )
+    # `length(input)` must be same as `length(output)`
+    if (!all(lengths(fill) == 1)) {
+      cli::cli_abort(msg)
+    }
+    return(unlist(fill))
+  }
+}
+
+# Similar to grid:::is.pattern
+is_pattern <- function(x) {
+  inherits(x, "GridPattern")
+}
+
+# Function that applies alpha to <GridPattern> objects.
+# For linear or radial gradients, this is as simple as modifying their `colours`
+# slot with an alpha.
+# For tiled patterns, we attach an alpha mask in the grobs' viewport.
+pattern_alpha <- function(x, alpha) {
+  if (!is.list(x)) {
+    # If this is a plain colour, convert to pattern because grid doesn't accept
+    # mixed patterns and plain colours.
+    out <- pattern(rectGrob(), gp = gpar(fill = alpha(x, alpha)))
+    return(out)
+  }
+  if (!is_pattern(x)) {
+    out <- Map(pattern_alpha, x = x, alpha = alpha)
+    return(out)
+  }
+  if (inherits(x, c("GridLinearGradient", "GridRadialGradient"))) {
+    # Apply alpha to gradient colours
+    x$colours <- alpha(x$colours, alpha[1])
+    return(x)
+  }
+  needs_alpha <- !(is.na(alpha[1]) || alpha[1] == 1)
+  if (needs_alpha && inherits(x, "GridTilingPattern") &&
+      check_device("alpha_masks", action = "warn")) {
+    # Dig out the grob from the function environment
+    grob <- env_get(environment(x$f), "grob")
+    # Apply a mask in the grob's viewport
+    mask <- as.mask(rectGrob(gp = gpar(fill = alpha("white", alpha[1]))))
+    if (is.null(grob$vp)) {
+      grob$vp <- viewport(mask = mask)
+    } else {
+      grob$vp$mask <- mask
+    }
+    # Re-attach new function environment
+    new_env <- new.env(parent = environment(x$f))
+    env_bind(new_env, grob = grob)
+    environment(x$f) <- new_env
+  }
+  return(x)
+}

tests/testthat/_snaps/patterns.md

@@ -0,0 +1,8 @@
+# fill_alpha works as expected
+
+    fill must be a vector of colours or list of <GridPattern> objects.
+
+---
+
+    fill must be a vector of colours or list of <GridPattern> objects.
+