From ad540b77d0fb1ed2e3e349089cd8acb5c1edeb78 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 8 Dec 2023 10:14:49 +0100 Subject: [PATCH] Barebones support for `` 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 --- DESCRIPTION | 1 + NAMESPACE | 6 + NEWS.md | 5 + R/backports.R | 23 +++ R/geom-.R | 4 + 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-raster.R | 4 + R/geom-rect.R | 2 +- R/geom-ribbon.R | 2 +- R/geom-tile.R | 3 +- R/legend-draw.R | 12 +- R/utilities-patterns.R | 115 +++++++++++++ man/fill_alpha.Rd | 33 ++++ man/geom_tile.Rd | 3 +- man/pattern_alpha.Rd | 22 +++ tests/testthat/_snaps/geom-raster.md | 7 + 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-geom-raster.R | 7 + tests/testthat/test-patterns.R | 118 +++++++++++++ 29 files changed, 883 insertions(+), 18 deletions(-) create mode 100644 R/utilities-patterns.R create mode 100644 man/fill_alpha.Rd create mode 100644 man/pattern_alpha.Rd 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/DESCRIPTION b/DESCRIPTION index c5c8af640e..1481517272 100644 --- a/DESCRIPTION +++ b/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' diff --git a/NAMESPACE b/NAMESPACE index 1e43aa78ad..b15bde6e2f 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) @@ -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) diff --git a/NEWS.md b/NEWS.md index cabdc6940b..7f984112bc 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). + * The plot's title, subtitle and caption now obey horizontal text margins (#5533). diff --git a/R/backports.R b/R/backports.R index 4679be5680..0fe48cc3ac 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()}.") +} + +# 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 + } +}) + diff --git a/R/geom-.R b/R/geom-.R index 9a6966e15b..6d4ed6fc55 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)) diff --git a/R/geom-boxplot.R b/R/geom-boxplot.R index b4f7777e6f..289c10cd97 100644 --- a/R/geom-boxplot.R +++ b/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 ) 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 a882979bf1..e3027096f1 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 41ba35f2fc..d83434b386 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 7ecfd09e0b..01024ebeff 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 ef9df0b652..1b39a11d46 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 2e1efb835c..c644d9daad 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-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/R/geom-rect.R b/R/geom-rect.R index 1d4108345d..d39978897a 100644 --- a/R/geom-rect.R +++ b/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, diff --git a/R/geom-ribbon.R b/R/geom-ribbon.R index ed6696bb39..d93df77850 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, diff --git a/R/geom-tile.R b/R/geom-tile.R index 02a696f430..8bc95fef12 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 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" ) diff --git a/R/utilities-patterns.R b/R/utilities-patterns.R new file mode 100644 index 0000000000..e7cdd308bc --- /dev/null +++ b/R/utilities-patterns.R @@ -0,0 +1,115 @@ + +#' 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 `` objects. +#' +#' @param fill A fill colour given as a `character` or `integer` vector, or as a +#' (list of) `` 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 `` 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 = "warn") + 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") +} + +#' 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) { + 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)}.") + } + 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) + } + 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) + } + 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/fill_alpha.Rd b/man/fill_alpha.Rd new file mode 100644 index 0000000000..8902d4cd38 --- /dev/null +++ b/man/fill_alpha.Rd @@ -0,0 +1,33 @@ +% 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{} object(s).} + +\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 \code{fill_alpha()} also attempts +to set the transparency of \verb{} objects. +} +\examples{ +# Typical colour input +fill_alpha("red", 0.5) + +if (utils::packageVersion("grid") > "4.2") { + # Pattern input + fill_alpha(list(grid::linearGradient()), 0.5) +} +} +\keyword{internal} diff --git a/man/geom_tile.Rd b/man/geom_tile.Rd index 39a6128cf7..00903da7f6 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 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} 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/_snaps/patterns.md b/tests/testthat/_snaps/patterns.md new file mode 100644 index 0000000000..5a9374a4d6 --- /dev/null +++ b/tests/testthat/_snaps/patterns.md @@ -0,0 +1,8 @@ +# fill_alpha works as expected + + fill must be a vector of colours or list of objects. + +--- + + fill must be a vector of colours 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..964a5b714b --- /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-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", { diff --git a/tests/testthat/test-patterns.R b/tests/testthat/test-patterns.R new file mode 100644 index 0000000000..8e2b64d82e --- /dev/null +++ b/tests/testthat/test-patterns.R @@ -0,0 +1,118 @@ +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), + c("#FF000080", "#00FF0080") + ) + + # List input + expect_identical( + fill_alpha(list("red", "green"), 0.5), + c("#FF000080", "#00FF0080") + ) + + skip_if_not_installed("grid", "4.2.0") + + # 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) + + # Handles plain, unlisted patterns + expect_identical( + fill_alpha(linearGradient(), 0.5)$colours, + c("#00000080", "#FFFFFF80") + ) +}) + +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 + ) +})