From 594c0119ce4f09adfaae4e33907d773477ff78c6 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sat, 6 May 2023 21:07:53 +0200 Subject: [PATCH 01/21] Write pattern utilities --- R/utilities-patterns.R | 102 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 102 insertions(+) create mode 100644 R/utilities-patterns.R diff --git a/R/utilities-patterns.R b/R/utilities-patterns.R new file mode 100644 index 0000000000..45fdc12d9b --- /dev/null +++ b/R/utilities-patterns.R @@ -0,0 +1,102 @@ + +#' Modify fill transparency +#' +#' This works much like [alpha()][scales::alpha] in that it modifies the +#' transparency of fill colours. It differs in that is also attempts to set +#' the transparency of `` objects. +#' +#' @param fill A fill colour given as a `character` or `integer` vector, or as a +#' list of `` objects. +#' @param alpha A transparency value between 0 (transparent) and 1 (opaque), +#' parallel to `fill`. +#' +#' @return A `character` vector of colours, or list of `` objects. +#' @export +#' +#' @examples +#' # Typical colour input +#' fill_alpha("red", 0.5) +#' +#' # Pattern input +#' fill_alpha(list(linearGradient()), 0.5) +fill_alpha <- function(fill, alpha) { + if (!is.list(fill)) { + # Happy path for no patterns + return(alpha(fill, alpha)) + } + if (any(vapply(fill, is_pattern, logical(1)))) { + if (utils::packageVersion("grid") < "4.2") { + # Pattern fills were introduced in R 4.1.0, but *vectorised* patterns + # were only introduced in R 4.2.0. + cli::cli_abort( + "Using patterns in {.pkg ggplot2} requires at least R version 4.2.0." + ) + } + 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 valid colour 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) + } + ) + # `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 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) + } + no_alpha <- is.na(alpha[1]) || alpha[1] == 1 + if (inherits(x, "GridTilingPattern") && !no_alpha) { + # 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("black", 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) +} From 1aca80904b4741885a0151349fadd02db3716750 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sat, 6 May 2023 21:08:35 +0200 Subject: [PATCH 02/21] Intercept non-list patterns --- R/geom-.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/geom-.R b/R/geom-.R index b9ff98a71f..65fc02ddfa 100644 --- a/R/geom-.R +++ b/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)) From 48b3a2acf876de2035328acd14a571c42699e61b Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sat, 6 May 2023 21:10:13 +0200 Subject: [PATCH 03/21] Support pattern fills in geoms --- R/geom-boxplot.R | 2 +- R/geom-dotplot.R | 2 +- R/geom-hex.R | 2 +- R/geom-label.R | 2 +- R/geom-map.R | 2 +- R/geom-point.R | 2 +- R/geom-polygon.R | 4 ++-- R/geom-rect.R | 2 +- R/geom-ribbon.R | 2 +- 9 files changed, 10 insertions(+), 10 deletions(-) diff --git a/R/geom-boxplot.R b/R/geom-boxplot.R index 6b4160dd88..b8b3a47761 100644 --- a/R/geom-boxplot.R +++ b/R/geom-boxplot.R @@ -226,7 +226,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 ) diff --git a/R/geom-dotplot.R b/R/geom-dotplot.R index 802a717c28..120fb80109 100644 --- a/R/geom-dotplot.R +++ b/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)) ) diff --git a/R/geom-hex.R b/R/geom-hex.R index 0e6af52745..ee4b17e629 100644 --- a/R/geom-hex.R +++ b/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, diff --git a/R/geom-label.R b/R/geom-label.R index 343a5ae28e..88014da607 100644 --- a/R/geom-label.R +++ b/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 ) ) diff --git a/R/geom-map.R b/R/geom-map.R index a1085fd75d..1f9c56c0f8 100644 --- a/R/geom-map.R +++ b/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, diff --git a/R/geom-point.R b/R/geom-point.R index a2e325d518..d4db9ac3f6 100644 --- a/R/geom-point.R +++ b/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 diff --git a/R/geom-polygon.R b/R/geom-polygon.R index 0558a64efe..b081faedad 100644 --- a/R/geom-polygon.R +++ b/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, diff --git a/R/geom-rect.R b/R/geom-rect.R index 00eee5fb48..1ef74e2e81 100644 --- a/R/geom-rect.R +++ b/R/geom-rect.R @@ -58,7 +58,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, diff --git a/R/geom-ribbon.R b/R/geom-ribbon.R index e889bb78a1..3bb3df0177 100644 --- a/R/geom-ribbon.R +++ b/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, From d47f0a180f40e45f13bb23ca77e863a82332a28e Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sat, 6 May 2023 21:10:44 +0200 Subject: [PATCH 04/21] Support pattern fills in keys --- R/legend-draw.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/R/legend-draw.R b/R/legend-draw.R index 5f8c202f07..e039e97ac3 100644 --- a/R/legend-draw.R +++ b/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" ) From 44dd11b7430203afbd9fd27260c51d826a3b490e Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sat, 6 May 2023 21:11:00 +0200 Subject: [PATCH 05/21] Note that `geom_raster()` cannot use pattern fills --- R/geom-tile.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/geom-tile.R b/R/geom-tile.R index f5bf2e5043..4530123f8f 100644 --- a/R/geom-tile.R +++ b/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 From 4e535cebad9d423de600664798e39488d039f6e4 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sat, 6 May 2023 22:13:37 +0200 Subject: [PATCH 06/21] More informative call in error message --- R/utilities-patterns.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utilities-patterns.R b/R/utilities-patterns.R index 45fdc12d9b..0d10e56161 100644 --- a/R/utilities-patterns.R +++ b/R/utilities-patterns.R @@ -46,7 +46,7 @@ fill_alpha <- function(fill, alpha) { fill <- try_fetch( Map(alpha, colour = fill, alpha = alpha), error = function(cnd) { - cli::cli_abort(msg) + cli::cli_abort(msg, call = expr(fill_alpha())) } ) # `length(input)` must be same as `length(output)` From 23d08f812a44d748e764d7c0d0eae4c118a288b9 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sat, 6 May 2023 22:14:20 +0200 Subject: [PATCH 07/21] Write tests --- tests/testthat/_snaps/patterns.md | 8 + .../patterns/pattern-fills-no-alpha.svg | 115 +++++++++++++ .../patterns/pattern-fills-through-scale.svg | 155 ++++++++++++++++++ .../patterns/pattern-fills-with-alpha.svg | 120 ++++++++++++++ .../_snaps/patterns/single-pattern-fill.svg | 120 ++++++++++++++ tests/testthat/test-patterns.R | 111 +++++++++++++ 6 files changed, 629 insertions(+) create mode 100644 tests/testthat/_snaps/patterns.md create mode 100644 tests/testthat/_snaps/patterns/pattern-fills-no-alpha.svg create mode 100644 tests/testthat/_snaps/patterns/pattern-fills-through-scale.svg create mode 100644 tests/testthat/_snaps/patterns/pattern-fills-with-alpha.svg create mode 100644 tests/testthat/_snaps/patterns/single-pattern-fill.svg create mode 100644 tests/testthat/test-patterns.R diff --git a/tests/testthat/_snaps/patterns.md b/tests/testthat/_snaps/patterns.md new file mode 100644 index 0000000000..9582595d23 --- /dev/null +++ b/tests/testthat/_snaps/patterns.md @@ -0,0 +1,8 @@ +# fill_alpha works as expected + + fill must be a valid colour or list of objects. + +--- + + fill must be a valid colour or list of objects. + diff --git a/tests/testthat/_snaps/patterns/pattern-fills-no-alpha.svg b/tests/testthat/_snaps/patterns/pattern-fills-no-alpha.svg new file mode 100644 index 0000000000..bdf29df500 --- /dev/null +++ b/tests/testthat/_snaps/patterns/pattern-fills-no-alpha.svg @@ -0,0 +1,115 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + +A +B +C +D +x +y +pattern fills, no alpha + + diff --git a/tests/testthat/_snaps/patterns/pattern-fills-through-scale.svg b/tests/testthat/_snaps/patterns/pattern-fills-through-scale.svg new file mode 100644 index 0000000000..a703f46c91 --- /dev/null +++ b/tests/testthat/_snaps/patterns/pattern-fills-through-scale.svg @@ -0,0 +1,155 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + +A +B +C +D +x +y + +x + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +A +B +C +D +pattern fills through scale + + diff --git a/tests/testthat/_snaps/patterns/pattern-fills-with-alpha.svg b/tests/testthat/_snaps/patterns/pattern-fills-with-alpha.svg new file mode 100644 index 0000000000..8b33e33832 --- /dev/null +++ b/tests/testthat/_snaps/patterns/pattern-fills-with-alpha.svg @@ -0,0 +1,120 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + +A +B +C +D +x +y +pattern fills, with alpha + + diff --git a/tests/testthat/_snaps/patterns/single-pattern-fill.svg b/tests/testthat/_snaps/patterns/single-pattern-fill.svg new file mode 100644 index 0000000000..9126ab0c7f --- /dev/null +++ b/tests/testthat/_snaps/patterns/single-pattern-fill.svg @@ -0,0 +1,120 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + +A +B +C +D +x +y +single pattern fill + + diff --git a/tests/testthat/test-patterns.R b/tests/testthat/test-patterns.R new file mode 100644 index 0000000000..11b2458b32 --- /dev/null +++ b/tests/testthat/test-patterns.R @@ -0,0 +1,111 @@ +test_that("fill_alpha works as expected", { + + # Vector input + expect_identical( + fill_alpha(c("red", "green"), 0.5), + c("#FF000080", "#00FF0080") + ) + + # List input + expect_identical( + fill_alpha(list("red", "green"), 0.5), + c("#FF000080", "#00FF0080") + ) + + # Linear gradients + expect_identical( + fill_alpha(list(linearGradient()), 0.5)[[1]]$colours, + c("#00000080", "#FFFFFF80") + ) + + # Radial gradients + expect_identical( + fill_alpha(list(radialGradient()), 0.5)[[1]]$colours, + c("#00000080", "#FFFFFF80") + ) + + # Tiled pattern + pat <- pattern( + rectGrob(c(0.25, 0.75), c(0.25, 0.75), width = 0.5, height = 0.5, + gp = gpar(fill = "black", col = NA)), + width = unit(1, "cm"), height = unit(1, "cm"), + extend = "repeat" + ) + # Constructed with empty viewport + expect_null(environment(pat$f)$grob$vp) + + ans <- fill_alpha(list(pat), 0.5) + + # Viewport should have mask + expect_s3_class(environment(ans[[1]]$f)$grob$vp$mask, "GridMask") + # Should not have altered original environment + expect_null(environment(pat$f)$grob$vp) + + + expect_snapshot_error( + fill_alpha(data.frame(x = 1:10, y = LETTERS[1:10]), 0.5) + ) + + expect_snapshot_error( + fill_alpha(list(list("red", "blue"), list("green", "orange")), 0.5) + ) +}) + +test_that("geoms can use pattern fills", { + + skip_if_not_installed("grid", "4.2.0") + skip_if_not_installed("svglite", "2.1.0") + + # Workaround for vdiffr's lack of pattern support + # See also https://github.com/r-lib/vdiffr/issues/132 + custom_svg <- function(plot, file, title = "") { + svglite::svglite(file) + on.exit(grDevices::dev.off()) + print( + plot + ggtitle(title) + theme_test() + ) + } + + patterns <- list( + linearGradient(group = FALSE), + radialGradient(group = FALSE), + pattern( + rectGrob(c(0.25, 0.75), c(0.25, 0.75), width = 0.5, height = 0.5, + gp = gpar(fill = "black", col = NA)), + width = unit(1, "cm"), height = unit(1, "cm"), + extend = "repeat" + ), + "black" + ) + + df <- data.frame(x = LETTERS[1:4], y = 2:5) + + expect_doppelganger( + "single pattern fill", + ggplot(df, aes(x, y)) + + geom_col(fill = patterns[3]), + writer = custom_svg + ) + + expect_doppelganger( + "pattern fills, no alpha", + ggplot(df, aes(x, y)) + + geom_col(fill = patterns), + writer = custom_svg + ) + + expect_doppelganger( + "pattern fills, with alpha", + ggplot(df, aes(x, y)) + + geom_col(fill = patterns, alpha = c(0.8, 0.6, 0.4, 0.2)), + writer = custom_svg + ) + + expect_doppelganger( + "pattern fills through scale", + ggplot(df, aes(x, y, fill = x)) + + geom_col() + + scale_fill_manual(values = rev(patterns)), + writer = custom_svg + ) +}) From 4baf67a9a24fe2004ee780bb57a4352a385449f7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sat, 6 May 2023 22:14:50 +0200 Subject: [PATCH 08/21] Document --- DESCRIPTION | 1 + NAMESPACE | 1 + man/fill_alpha.Rd | 30 ++++++++++++++++++++++++++++++ man/geom_tile.Rd | 3 ++- 4 files changed, 34 insertions(+), 1 deletion(-) create mode 100644 man/fill_alpha.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 22f4670da0..8689d260d7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -270,6 +270,7 @@ Collate: 'utilities-grid.R' 'utilities-help.R' 'utilities-matrix.R' + 'utilities-patterns.R' 'utilities-resolution.R' 'utilities-table.R' 'utilities-tidy-eval.R' diff --git a/NAMESPACE b/NAMESPACE index 41676e5022..7bb50293e2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -341,6 +341,7 @@ export(expr) export(facet_grid) export(facet_null) export(facet_wrap) +export(fill_alpha) export(find_panel) export(flip_data) export(flipped_names) diff --git a/man/fill_alpha.Rd b/man/fill_alpha.Rd new file mode 100644 index 0000000000..4a30f8bace --- /dev/null +++ b/man/fill_alpha.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities-patterns.R +\name{fill_alpha} +\alias{fill_alpha} +\title{Modify fill transparency} +\usage{ +fill_alpha(fill, alpha) +} +\arguments{ +\item{fill}{A fill colour given as a \code{character} or \code{integer} vector, or as a +list of \verb{} objects.} + +\item{alpha}{A transparency value between 0 (transparent) and 1 (opaque), +parallel to \code{fill}.} +} +\value{ +A \code{character} vector of colours, or list of \verb{} objects. +} +\description{ +This works much like \link[scales:alpha]{alpha()} in that it modifies the +transparency of fill colours. It differs in that is also attempts to set +the transparency of \verb{} objects. +} +\examples{ +# Typical colour input +fill_alpha("red", 0.5) + +# Pattern input +fill_alpha(list(linearGradient()), 0.5) +} diff --git a/man/geom_tile.Rd b/man/geom_tile.Rd index be494fe6d1..8d5ab8e372 100644 --- a/man/geom_tile.Rd +++ b/man/geom_tile.Rd @@ -109,7 +109,8 @@ parameterised differently: \code{geom_rect()} uses the locations of the four corners (\code{xmin}, \code{xmax}, \code{ymin} and \code{ymax}), while \code{geom_tile()} uses the center of the tile and its size (\code{x}, \code{y}, \code{width}, \code{height}). \code{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. } \details{ \code{geom_rect()} and \code{geom_tile()}'s respond differently to scale From 3672fb8efc95e6115aa9c468d0b360b6481bca3c Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sat, 6 May 2023 22:51:12 +0200 Subject: [PATCH 09/21] Some version protections --- R/utilities-patterns.R | 7 +++++-- man/fill_alpha.Rd | 7 +++++-- tests/testthat/test-patterns.R | 19 ++++++++++--------- 3 files changed, 20 insertions(+), 13 deletions(-) diff --git a/R/utilities-patterns.R b/R/utilities-patterns.R index 0d10e56161..91f7f233cd 100644 --- a/R/utilities-patterns.R +++ b/R/utilities-patterns.R @@ -12,13 +12,16 @@ #' #' @return A `character` vector of colours, or list of `` objects. #' @export +#' @keywords internal #' #' @examples #' # Typical colour input #' fill_alpha("red", 0.5) #' -#' # Pattern input -#' fill_alpha(list(linearGradient()), 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 diff --git a/man/fill_alpha.Rd b/man/fill_alpha.Rd index 4a30f8bace..79d66033a4 100644 --- a/man/fill_alpha.Rd +++ b/man/fill_alpha.Rd @@ -25,6 +25,9 @@ the transparency of \verb{} objects. # Typical colour input fill_alpha("red", 0.5) -# Pattern input -fill_alpha(list(linearGradient()), 0.5) +if (utils::packageVersion("grid") > "4.2") { + # Pattern input + fill_alpha(list(grid::linearGradient()), 0.5) } +} +\keyword{internal} diff --git a/tests/testthat/test-patterns.R b/tests/testthat/test-patterns.R index 11b2458b32..8cca3502d4 100644 --- a/tests/testthat/test-patterns.R +++ b/tests/testthat/test-patterns.R @@ -1,5 +1,13 @@ test_that("fill_alpha works as expected", { + expect_snapshot_error( + fill_alpha(data.frame(x = 1:10, y = LETTERS[1:10]), 0.5) + ) + + expect_snapshot_error( + fill_alpha(list(list("red", "blue"), list("green", "orange")), 0.5) + ) + # Vector input expect_identical( fill_alpha(c("red", "green"), 0.5), @@ -12,6 +20,8 @@ test_that("fill_alpha works as expected", { c("#FF000080", "#00FF0080") ) + skip_if_not_installed("grid", "4.2.0") + # Linear gradients expect_identical( fill_alpha(list(linearGradient()), 0.5)[[1]]$colours, @@ -40,15 +50,6 @@ test_that("fill_alpha works as expected", { expect_s3_class(environment(ans[[1]]$f)$grob$vp$mask, "GridMask") # Should not have altered original environment expect_null(environment(pat$f)$grob$vp) - - - expect_snapshot_error( - fill_alpha(data.frame(x = 1:10, y = LETTERS[1:10]), 0.5) - ) - - expect_snapshot_error( - fill_alpha(list(list("red", "blue"), list("green", "orange")), 0.5) - ) }) test_that("geoms can use pattern fills", { From e54329c99354feb961c14a2321d3b3f64f895e51 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 6 Oct 2023 10:33:10 +0200 Subject: [PATCH 10/21] Use device checker --- R/utilities-patterns.R | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/R/utilities-patterns.R b/R/utilities-patterns.R index 91f7f233cd..c5b3da14a6 100644 --- a/R/utilities-patterns.R +++ b/R/utilities-patterns.R @@ -28,13 +28,7 @@ fill_alpha <- function(fill, alpha) { return(alpha(fill, alpha)) } if (any(vapply(fill, is_pattern, logical(1)))) { - if (utils::packageVersion("grid") < "4.2") { - # Pattern fills were introduced in R 4.1.0, but *vectorised* patterns - # were only introduced in R 4.2.0. - cli::cli_abort( - "Using patterns in {.pkg ggplot2} requires at least R version 4.2.0." - ) - } + check_device("patterns", action = "abort") fill <- pattern_alpha(fill, alpha) return(fill) } else { From 96736f53df065f71896023549f8bcd8043b5d8f9 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 6 Oct 2023 11:25:24 +0200 Subject: [PATCH 11/21] Set white alpha mask --- R/utilities-patterns.R | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/R/utilities-patterns.R b/R/utilities-patterns.R index c5b3da14a6..b7a97b3a3f 100644 --- a/R/utilities-patterns.R +++ b/R/utilities-patterns.R @@ -79,12 +79,13 @@ pattern_alpha <- function(x, alpha) { x$colours <- alpha(x$colours, alpha[1]) return(x) } - no_alpha <- is.na(alpha[1]) || alpha[1] == 1 - if (inherits(x, "GridTilingPattern") && !no_alpha) { + 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("black", alpha[1])))) + mask <- as.mask(rectGrob(gp = gpar(fill = alpha("white", alpha[1])))) if (is.null(grob$vp)) { grob$vp <- viewport(mask = mask) } else { From 2ad2474ed99f3d898d3e13ba511a8041e0e89c84 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 9 Oct 2023 09:30:30 +0200 Subject: [PATCH 12/21] Clarify error message --- R/utilities-patterns.R | 2 +- tests/testthat/_snaps/patterns.md | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/utilities-patterns.R b/R/utilities-patterns.R index b7a97b3a3f..030ad6b742 100644 --- a/R/utilities-patterns.R +++ b/R/utilities-patterns.R @@ -36,7 +36,7 @@ fill_alpha <- function(fill, alpha) { # 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 valid colour or list of ", + "{.field fill} must be a vector of colours or list of ", "{.cls GridPattern} objects." ) # If single colour list, try applying `alpha()` diff --git a/tests/testthat/_snaps/patterns.md b/tests/testthat/_snaps/patterns.md index 9582595d23..5a9374a4d6 100644 --- a/tests/testthat/_snaps/patterns.md +++ b/tests/testthat/_snaps/patterns.md @@ -1,8 +1,8 @@ # fill_alpha works as expected - fill must be a valid colour or list of objects. + fill must be a vector of colours or list of objects. --- - fill must be a valid colour or list of objects. + fill must be a vector of colours or list of objects. From 1512f29ed6682224336ca4b7605af752d5b8cf1d Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 9 Oct 2023 15:59:11 +0200 Subject: [PATCH 13/21] deal with unavailable functions/arguments --- R/backports.R | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/R/backports.R b/R/backports.R index 9f9d1f36df..f745b43f09 100644 --- a/R/backports.R +++ b/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()}.") +} + +viewport <- grid::viewport +pattern <- version_unavailable +as.mask <- version_unavailable +on_load({ + # Ignore mask argument if on lower R version (<= 4.1) + if (!"mask" %in% fn_fmls_names(grid::viewport)) { + viewport <- function(..., mask) 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 + } +}) + From 11f20d6e39df6cb42fc060e7e4d2f1ac1658fee3 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Thu, 12 Oct 2023 14:27:34 +0200 Subject: [PATCH 14/21] typo --- R/utilities-patterns.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utilities-patterns.R b/R/utilities-patterns.R index 030ad6b742..07e76c3665 100644 --- a/R/utilities-patterns.R +++ b/R/utilities-patterns.R @@ -2,8 +2,8 @@ #' Modify fill transparency #' #' This works much like [alpha()][scales::alpha] in that it modifies the -#' transparency of fill colours. It differs in that is also attempts to set -#' the transparency of `` objects. +#' transparency of fill colours. It differs in that `fill_alpha()` also attempts +#' to set the transparency of `` objects. #' #' @param fill A fill colour given as a `character` or `integer` vector, or as a #' list of `` objects. From 6d65104a25a31714b8c41847eaa6c82fe8f85804 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Thu, 12 Oct 2023 14:32:24 +0200 Subject: [PATCH 15/21] Also handle unlisted pattern --- R/utilities-patterns.R | 4 ++-- man/fill_alpha.Rd | 6 +++--- tests/testthat/test-patterns.R | 6 ++++++ 3 files changed, 11 insertions(+), 5 deletions(-) diff --git a/R/utilities-patterns.R b/R/utilities-patterns.R index 07e76c3665..a89c06f249 100644 --- a/R/utilities-patterns.R +++ b/R/utilities-patterns.R @@ -6,7 +6,7 @@ #' to set the transparency of `` objects. #' #' @param fill A fill colour given as a `character` or `integer` vector, or as a -#' list of `` objects. +#' (list of) `` object(s). #' @param alpha A transparency value between 0 (transparent) and 1 (opaque), #' parallel to `fill`. #' @@ -27,7 +27,7 @@ fill_alpha <- function(fill, alpha) { # Happy path for no patterns return(alpha(fill, alpha)) } - if (any(vapply(fill, is_pattern, logical(1)))) { + if (is_pattern(fill) || any(vapply(fill, is_pattern, logical(1)))) { check_device("patterns", action = "abort") fill <- pattern_alpha(fill, alpha) return(fill) diff --git a/man/fill_alpha.Rd b/man/fill_alpha.Rd index 79d66033a4..8902d4cd38 100644 --- a/man/fill_alpha.Rd +++ b/man/fill_alpha.Rd @@ -8,7 +8,7 @@ fill_alpha(fill, alpha) } \arguments{ \item{fill}{A fill colour given as a \code{character} or \code{integer} vector, or as a -list of \verb{} objects.} +(list of) \verb{} object(s).} \item{alpha}{A transparency value between 0 (transparent) and 1 (opaque), parallel to \code{fill}.} @@ -18,8 +18,8 @@ A \code{character} vector of colours, or list of \verb{} objects. } \description{ This works much like \link[scales:alpha]{alpha()} in that it modifies the -transparency of fill colours. It differs in that is also attempts to set -the transparency of \verb{} objects. +transparency of fill colours. It differs in that \code{fill_alpha()} also attempts +to set the transparency of \verb{} objects. } \examples{ # Typical colour input diff --git a/tests/testthat/test-patterns.R b/tests/testthat/test-patterns.R index 8cca3502d4..8e2b64d82e 100644 --- a/tests/testthat/test-patterns.R +++ b/tests/testthat/test-patterns.R @@ -50,6 +50,12 @@ test_that("fill_alpha works as expected", { expect_s3_class(environment(ans[[1]]$f)$grob$vp$mask, "GridMask") # Should not have altered original environment expect_null(environment(pat$f)$grob$vp) + + # Handles plain, unlisted patterns + expect_identical( + fill_alpha(linearGradient(), 0.5)$colours, + c("#00000080", "#FFFFFF80") + ) }) test_that("geoms can use pattern fills", { From a4455f9bf992e7b2bd6b07453139cbb54693004a Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Thu, 12 Oct 2023 14:56:52 +0200 Subject: [PATCH 16/21] Invert viewport backport --- R/backports.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/backports.R b/R/backports.R index f745b43f09..4349aaff42 100644 --- a/R/backports.R +++ b/R/backports.R @@ -28,13 +28,13 @@ version_unavailable <- function(...) { cli::cli_abort("{.fn {fun}} is not available in R version {getRversion()}.") } -viewport <- grid::viewport +# Ignore mask argument if on lower R version (<= 4.1) +viewport <- function(..., mask) grid::viewport(...) pattern <- version_unavailable as.mask <- version_unavailable on_load({ - # Ignore mask argument if on lower R version (<= 4.1) - if (!"mask" %in% fn_fmls_names(grid::viewport)) { - viewport <- function(..., mask) grid::viewport(...) + if ("mask" %in% fn_fmls_names(grid::viewport)) { + viewport <- grid::viewport } # Replace version unavailable functions if found if ("pattern" %in% getNamespaceExports("grid")) { From b1e0126e761c6062eeb67f5943d091d5029758c5 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 6 Dec 2023 10:38:43 +0100 Subject: [PATCH 17/21] `geom_raster()` throws error when fill is pattern --- R/geom-raster.R | 4 ++++ tests/testthat/_snaps/geom-raster.md | 7 +++++++ tests/testthat/test-geom-raster.R | 7 +++++++ 3 files changed, 18 insertions(+) diff --git a/R/geom-raster.R b/R/geom-raster.R index c3709a7d98..2cd591d879 100644 --- a/R/geom-raster.R +++ b/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) diff --git a/tests/testthat/_snaps/geom-raster.md b/tests/testthat/_snaps/geom-raster.md index 90bdd9dc0b..16da7d9d54 100644 --- a/tests/testthat/_snaps/geom-raster.md +++ b/tests/testthat/_snaps/geom-raster.md @@ -21,3 +21,10 @@ Caused by error in `draw_panel()`: ! `geom_raster()` only works with `coord_cartesian()`. +# geom_raster() fails with pattern fills + + Problem while converting geom to grob. + i Error occurred in the 1st layer. + Caused by error in `draw_panel()`: + ! `geom_raster()` cannot render pattern fills. + diff --git a/tests/testthat/test-geom-raster.R b/tests/testthat/test-geom-raster.R index 081abc5c20..2dfa1106e3 100644 --- a/tests/testthat/test-geom-raster.R +++ b/tests/testthat/test-geom-raster.R @@ -9,6 +9,13 @@ test_that("geom_raster() checks input and coordinate system", { expect_snapshot_error(ggplotGrob(p)) }) +test_that("geom_raster() fails with pattern fills", { + skip_if_not(getRversion() > "4.2", message = "pattern fills are unavailalbe") + df <- data.frame(x = 1) + p <- ggplot(df, aes(x, x)) + geom_raster(fill = linearGradient()) + expect_snapshot_error(ggplotGrob(p)) +}) + # Visual tests ------------------------------------------------------------ test_that("geom_raster draws correctly", { From 8ed05646df001cc800488a68764473740953bf15 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 6 Dec 2023 10:41:09 +0100 Subject: [PATCH 18/21] device check warns instead of aborts --- R/utilities-patterns.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utilities-patterns.R b/R/utilities-patterns.R index a89c06f249..0ed5967e5f 100644 --- a/R/utilities-patterns.R +++ b/R/utilities-patterns.R @@ -28,7 +28,7 @@ fill_alpha <- function(fill, alpha) { return(alpha(fill, alpha)) } if (is_pattern(fill) || any(vapply(fill, is_pattern, logical(1)))) { - check_device("patterns", action = "abort") + check_device("patterns", action = "warn") fill <- pattern_alpha(fill, alpha) return(fill) } else { From 3f9d4acc904ac58f7f0ef9a867c27e38990175ae Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 6 Dec 2023 11:12:15 +0100 Subject: [PATCH 19/21] reimplement `pattern_alpha` as S3 generic + methods --- NAMESPACE | 5 +++ R/utilities-patterns.R | 81 +++++++++++++++++++++++++----------------- man/pattern_alpha.Rd | 22 ++++++++++++ 3 files changed, 75 insertions(+), 33 deletions(-) create mode 100644 man/pattern_alpha.Rd diff --git a/NAMESPACE b/NAMESPACE index 9a4c3554ea..000bc1a6a2 100644 --- a/NAMESPACE +++ b/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) @@ -475,6 +479,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) diff --git a/R/utilities-patterns.R b/R/utilities-patterns.R index 0ed5967e5f..e7cdd308bc 100644 --- a/R/utilities-patterns.R +++ b/R/utilities-patterns.R @@ -59,42 +59,57 @@ is_pattern <- function(x) { inherits(x, "GridPattern") } -# Function that applies alpha to 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. +#' Modify transparency for patterns +#' +#' This generic allows you to add your own methods for adding transparency to +#' pattern-like objects. +#' +#' @param x Object to be interpreted as pattern. +#' @param alpha A `numeric` vector between 0 and 1. If `NA`, alpha values +#' are preserved. +#' +#' @return `x` with modified transparency +#' @export +#' @keywords internal 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) + UseMethod("pattern_alpha") +} + +#' @export +pattern_alpha.default <- function(x, alpha) { + if (!is.atomic(x)) { + cli::cli_abort("Can't apply {.arg alpha} to {obj_type_friendly(x)}.") } - if (inherits(x, c("GridLinearGradient", "GridRadialGradient"))) { - # Apply alpha to gradient colours - x$colours <- alpha(x$colours, alpha[1]) + pattern(rectGrob(), gp = gpar(fill = alpha(x, alpha))) +} + +#' @export +pattern_alpha.GridPattern <- function(x, alpha) { + x$colours <- alpha(x$colours, alpha[1]) + x +} + +#' @export +pattern_alpha.GridTilingPattern <- function(x, alpha) { + if (all(is.na(alpha) | 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 + check_device("alpha_masks", "warn") + grob <- env_get(environment(x$f), "grob") + mask <- as.mask(rectGrob(gp = gpar(fill = alpha("white", alpha)))) + if (is.null(grob$vp)) { + grob$vp <- viewport(mask = mask) + } else { + grob$vp <- editViewport(grob$vp, mask = mask) } - return(x) + new_env <- new.env(parent = environment(x$f)) + env_bind(new_env, grob = grob) + environment(x$f) <- new_env + x } + +#' @export +pattern_alpha.list <- function(x, alpha) { + Map(pattern_alpha, x = x, alpha = alpha) +} + diff --git a/man/pattern_alpha.Rd b/man/pattern_alpha.Rd new file mode 100644 index 0000000000..3c481d23b1 --- /dev/null +++ b/man/pattern_alpha.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities-patterns.R +\name{pattern_alpha} +\alias{pattern_alpha} +\title{Modify transparency for patterns} +\usage{ +pattern_alpha(x, alpha) +} +\arguments{ +\item{x}{Object to be interpreted as pattern.} + +\item{alpha}{A \code{numeric} vector between 0 and 1. If \code{NA}, alpha values +are preserved.} +} +\value{ +\code{x} with modified transparency +} +\description{ +This generic allows you to add your own methods for adding transparency to +pattern-like objects. +} +\keyword{internal} From 036ce01ea258754471a7db7d49bb71b5139c1424 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 6 Dec 2023 11:20:47 +0100 Subject: [PATCH 20/21] accept new snapshot --- tests/testthat/_snaps/patterns/pattern-fills-with-alpha.svg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/_snaps/patterns/pattern-fills-with-alpha.svg b/tests/testthat/_snaps/patterns/pattern-fills-with-alpha.svg index 8b33e33832..964a5b714b 100644 --- a/tests/testthat/_snaps/patterns/pattern-fills-with-alpha.svg +++ b/tests/testthat/_snaps/patterns/pattern-fills-with-alpha.svg @@ -62,7 +62,7 @@ - + From c44efb5283b58dfd8427c7438c582f950f4e081b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 8 Dec 2023 09:49:08 +0100 Subject: [PATCH 21/21] Add news bullet --- NEWS.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/NEWS.md b/NEWS.md index 96ca2cdf69..1f293ffe26 100644 --- a/NEWS.md +++ b/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). + * New `guide_custom()` function for drawing custom graphical objects (grobs) unrelated to scales in legend positions (#5416).