Merge branch 'main' into ignore_asis2

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)
@@ -356,6 +360,7 @@ export(expr)
 export(facet_grid)
 export(facet_null)
 export(facet_wrap)
+export(fill_alpha)
 export(find_panel)
 export(flip_data)
 export(flipped_names)
@@ -478,6 +483,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

@@ -5,6 +5,14 @@
   layers that need a non-identity scale for the same aesthetic. Also, it makes
   it easy to specify relative positions (@teunbrand, #5142).
 
+* 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).
+
 * New `guide_axis_stack()` to combine other axis guides on top of one another.
 
 * New `guide_custom()` function for drawing custom graphical objects (grobs)

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-raster.R

@@ -102,6 +102,10 @@ GeomRaster <- ggproto("GeomRaster", Geom,
     nrow <- max(y_pos) + 1
     ncol <- max(x_pos) + 1
 
+    if (is.list(data$fill) && is_pattern(data$fill[[1]])) {
+      cli::cli_abort("{.fn {snake_class(self)}} cannot render pattern fills.")
+    }
+
     raster <- matrix(NA_character_, nrow = nrow, ncol = ncol)
     raster[cbind(nrow - y_pos, x_pos + 1)] <- alpha(data$fill, data$alpha)
 

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-segment.R

@@ -103,15 +103,15 @@ geom_segment <- function(mapping = NULL, data = NULL,
 #' @export
 GeomSegment <- ggproto("GeomSegment", Geom,
   required_aes = c("x", "y", "xend|yend"),
-  non_missing_aes = c("linetype", "linewidth", "shape"),
+  non_missing_aes = c("linetype", "linewidth"),
   default_aes = aes(colour = "black", linewidth = 0.5, linetype = 1, alpha = NA),
   draw_panel = function(self, data, panel_params, coord, arrow = NULL, arrow.fill = NULL,
                         lineend = "butt", linejoin = "round", na.rm = FALSE) {
     data$xend <- data$xend %||% data$x
     data$yend <- data$yend %||% data$y
     data <- check_linewidth(data, snake_class(self))
     data <- remove_missing(data, na.rm = na.rm,
-      c("x", "y", "xend", "yend", "linetype", "linewidth", "shape"),
+      c("x", "y", "xend", "yend", "linetype", "linewidth"),
       name = "geom_segment"
     )
 

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/plot-build.R

@@ -269,15 +269,24 @@ ggplot_gtable.ggplot_built <- function(data) {
   }
 
   # Title
-  title <- element_render(theme, "plot.title", plot$labels$title, margin_y = TRUE)
+  title <- element_render(
+    theme, "plot.title", plot$labels$title,
+    margin_y = TRUE, margin_x = TRUE
+  )
   title_height <- grobHeight(title)
 
   # Subtitle
-  subtitle <- element_render(theme, "plot.subtitle", plot$labels$subtitle, margin_y = TRUE)
+  subtitle <- element_render(
+    theme, "plot.subtitle", plot$labels$subtitle,
+    margin_y = TRUE, margin_x = TRUE
+  )
   subtitle_height <- grobHeight(subtitle)
 
   # whole plot annotation
-  caption <- element_render(theme, "plot.caption", plot$labels$caption, margin_y = TRUE)
+  caption <- element_render(
+    theme, "plot.caption", plot$labels$caption,
+    margin_y = TRUE, margin_x = TRUE
+  )
   caption_height <- grobHeight(caption)
 
   # positioning of title and subtitle is governed by plot.title.position