From 41587fc1c1ebca39e7abb4af019c05b6d0736b4f Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Wed, 6 Dec 2023 11:36:31 +0100 Subject: [PATCH 1/4] remove shape as non-missing aes (#5546) --- R/geom-segment.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/geom-segment.R b/R/geom-segment.R index 611ba85e2c..f32b61f876 100644 --- a/R/geom-segment.R +++ b/R/geom-segment.R @@ -103,7 +103,7 @@ 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) { @@ -111,7 +111,7 @@ GeomSegment <- ggproto("GeomSegment", Geom, 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" ) From 5c7867d64e7b679c28e11dd73a8bd6da47e40ffa Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Wed, 6 Dec 2023 11:56:02 +0100 Subject: [PATCH 2/4] Silence tests (#5507) * set dotplot binwidth * set number of bins * fill in smooth defaults * silence coord replacements * stat_summary2d has been replace by stat_summary_2d * fill quantile formula * suppress scale type messages * suppress sp-related messages * use explicit tempfiles * Include snapshot renaming from #5504 --- ...=> scale-x-date-labels-label-date-m-d.svg} | 2 +- ...scale-x-date-labels-label-date-w-week.svg} | 2 +- tests/testthat/test-fortify.R | 11 ++++++++--- tests/testthat/test-function-args.R | 4 ++-- tests/testthat/test-geom-dotplot.R | 6 +++--- tests/testthat/test-geom-hline-vline-abline.R | 10 ++++------ tests/testthat/test-geom-quantile.R | 2 +- tests/testthat/test-geom-smooth.R | 10 ++++++---- tests/testthat/test-layer.R | 19 +++++++++++++------ tests/testthat/test-stat-bin.R | 6 +++--- tests/testthat/test-utilities-checks.R | 6 ++++-- 11 files changed, 46 insertions(+), 32 deletions(-) rename tests/testthat/_snaps/scale_date/{scale-x-date-labels-date-format-m-d.svg => scale-x-date-labels-label-date-m-d.svg} (97%) rename tests/testthat/_snaps/scale_date/{scale-x-date-labels-date-format-w-week.svg => scale-x-date-labels-label-date-w-week.svg} (97%) diff --git a/tests/testthat/_snaps/scale_date/scale-x-date-labels-date-format-m-d.svg b/tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-m-d.svg similarity index 97% rename from tests/testthat/_snaps/scale_date/scale-x-date-labels-date-format-m-d.svg rename to tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-m-d.svg index 49346a1c5e..1fef513fa1 100644 --- a/tests/testthat/_snaps/scale_date/scale-x-date-labels-date-format-m-d.svg +++ b/tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-m-d.svg @@ -51,6 +51,6 @@ 06/01 dx price -scale_x_date(labels = date_format("%m/%d")) +scale_x_date(labels = label_date("%m/%d")) diff --git a/tests/testthat/_snaps/scale_date/scale-x-date-labels-date-format-w-week.svg b/tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-w-week.svg similarity index 97% rename from tests/testthat/_snaps/scale_date/scale-x-date-labels-date-format-w-week.svg rename to tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-w-week.svg index fa832b94e5..1748ed74f5 100644 --- a/tests/testthat/_snaps/scale_date/scale-x-date-labels-date-format-w-week.svg +++ b/tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-w-week.svg @@ -51,6 +51,6 @@ 22 week price -scale_x_date(labels = date_format("%W"), "week") +scale_x_date(labels = label_date("%W"), "week") diff --git a/tests/testthat/test-fortify.R b/tests/testthat/test-fortify.R index 43b7adb74c..03980c19c1 100644 --- a/tests/testthat/test-fortify.R +++ b/tests/testthat/test-fortify.R @@ -1,5 +1,8 @@ test_that("spatial polygons have correct ordering", { - skip_if_not_installed("sp") + suppressPackageStartupMessages({ + skip_if_not_installed("sp") + }) + make_square <- function(x = 0, y = 0, height = 1, width = 1){ delx <- width/2 @@ -30,12 +33,14 @@ test_that("spatial polygons have correct ordering", { polys2_sp <- sp::SpatialPolygons(polys2) fake_sp2 <- sp::SpatialPolygonsDataFrame(polys2_sp, fake_data) lifecycle::expect_deprecated( - expected <- fortify(fake_sp2) + # supressing: Regions defined for each Polygons + expected <- suppressMessages(fortify(fake_sp2)) ) expected <- expected[order(expected$id, expected$order), ] lifecycle::expect_deprecated( - actual <- fortify(fake_sp) + # supressing: Regions defined for each Polygons + actual <- suppressMessages(fortify(fake_sp)) ) # the levels are different, so these columns need to be converted to character to compare diff --git a/tests/testthat/test-function-args.R b/tests/testthat/test-function-args.R index 6be2567689..2a78bf9f50 100644 --- a/tests/testthat/test-function-args.R +++ b/tests/testthat/test-function-args.R @@ -50,8 +50,8 @@ test_that("stat_xxx and StatXxx$compute_panel arg defaults match", { stat_fun_names, c("stat_function", "stat_sf") ) - # Remove stat_spoke as it has been deprecated - stat_fun_names <- setdiff(stat_fun_names, "stat_spoke") + # Remove deprecated stats + stat_fun_names <- setdiff(stat_fun_names, c("stat_spoke", "stat_summary2d")) # For each stat_xxx function and the corresponding StatXxx$compute_panel and # StatXxx$compute_group functions, make sure that if they have same args, that diff --git a/tests/testthat/test-geom-dotplot.R b/tests/testthat/test-geom-dotplot.R index a095158937..69b7d65a75 100644 --- a/tests/testthat/test-geom-dotplot.R +++ b/tests/testthat/test-geom-dotplot.R @@ -63,7 +63,7 @@ test_that("NA's result in warning from stat_bindot", { test_that("when binning on y-axis, limits depend on the panel", { p <- ggplot(mtcars, aes(factor(cyl), mpg)) + - geom_dotplot(binaxis='y') + geom_dotplot(binaxis='y', binwidth = 1/30 * diff(range(mtcars$mpg))) b1 <- ggplot_build(p + facet_wrap(~am)) b2 <- ggplot_build(p + facet_wrap(~am, scales = "free_y")) @@ -77,10 +77,10 @@ test_that("when binning on y-axis, limits depend on the panel", { test_that("weight aesthetic is checked", { p <- ggplot(mtcars, aes(x = mpg, weight = gear/3)) + - geom_dotplot() + geom_dotplot(binwidth = 1/30 * diff(range(mtcars$mpg))) expect_snapshot_warning(ggplot_build(p)) p <- ggplot(mtcars, aes(x = mpg, weight = -gear)) + - geom_dotplot() + geom_dotplot(binwidth = 1/30 * diff(range(mtcars$mpg))) expect_snapshot_warning(ggplot_build(p)) }) diff --git a/tests/testthat/test-geom-hline-vline-abline.R b/tests/testthat/test-geom-hline-vline-abline.R index 61510a3c7c..b637cd0a2f 100644 --- a/tests/testthat/test-geom-hline-vline-abline.R +++ b/tests/testthat/test-geom-hline-vline-abline.R @@ -9,12 +9,11 @@ test_that("check h/v/abline transformed on basic projections", { geom_vline(xintercept = 3, colour = "red") + geom_hline(yintercept = 3, colour = "blue") + geom_abline(intercept = 0, slope = 1, colour = "purple") + - labs(x = NULL, y = NULL) + - coord_cartesian(expand = FALSE) + labs(x = NULL, y = NULL) expect_doppelganger( "cartesian lines intersect mid-bars", - plot + plot + coord_cartesian(expand = FALSE) ) expect_doppelganger( "flipped lines intersect mid-bars", @@ -34,11 +33,10 @@ test_that("curved lines in map projections", { nzmap <- ggplot(nz, aes(long, lat, group = group)) + geom_path() + geom_hline(yintercept = -38.6) + # roughly Taupo - geom_vline(xintercept = 176) + - coord_map() + geom_vline(xintercept = 176) expect_doppelganger("straight lines in mercator", - nzmap + nzmap + coord_map() ) expect_doppelganger("lines curved in azequalarea", nzmap + coord_map(projection = 'azequalarea', orientation = c(-36.92, 174.6, 0)) diff --git a/tests/testthat/test-geom-quantile.R b/tests/testthat/test-geom-quantile.R index 710f88436d..d9eaf84184 100644 --- a/tests/testthat/test-geom-quantile.R +++ b/tests/testthat/test-geom-quantile.R @@ -13,7 +13,7 @@ test_that("geom_quantile matches quantile regression", { y = x^2 + 0.5 * rnorm(10) ) - ps <- ggplot(df, aes(x, y)) + geom_quantile() + ps <- ggplot(df, aes(x, y)) + geom_quantile(formula = y ~ x) quants <- c(0.25, 0.5, 0.75) diff --git a/tests/testthat/test-geom-smooth.R b/tests/testthat/test-geom-smooth.R index ca57bd2e38..e71df88485 100644 --- a/tests/testthat/test-geom-smooth.R +++ b/tests/testthat/test-geom-smooth.R @@ -8,11 +8,13 @@ test_that("data is ordered by x", { }) test_that("geom_smooth works in both directions", { - p <- ggplot(mpg, aes(displ, hwy)) + geom_smooth() + p <- ggplot(mpg, aes(displ, hwy)) + + geom_smooth(method = 'loess', formula = y ~ x) x <- layer_data(p) expect_false(x$flipped_aes[1]) - p <- ggplot(mpg, aes(hwy, displ)) + geom_smooth(orientation = "y") + p <- ggplot(mpg, aes(hwy, displ)) + + geom_smooth(orientation = "y", method = 'loess', formula = y ~ x) y <- layer_data(p) expect_true(y$flipped_aes[1]) @@ -103,11 +105,11 @@ test_that("geom_smooth() works with alternative stats", { expect_doppelganger("ribbon turned on in geom_smooth", { ggplot(df, aes(x, y, color = fill, fill = fill)) + - geom_smooth(stat = "summary") # ribbon on by default + geom_smooth(stat = "summary", fun.data = mean_se) # ribbon on by default }) expect_doppelganger("ribbon turned off in geom_smooth", { ggplot(df, aes(x, y, color = fill, fill = fill)) + - geom_smooth(stat = "summary", se = FALSE) # ribbon is turned off via `se = FALSE` + geom_smooth(stat = "summary", se = FALSE, fun.data = mean_se) # ribbon is turned off via `se = FALSE` }) }) diff --git a/tests/testthat/test-layer.R b/tests/testthat/test-layer.R index 58ae5051bd..b0507cf7ae 100644 --- a/tests/testthat/test-layer.R +++ b/tests/testthat/test-layer.R @@ -26,10 +26,13 @@ test_that("unknown aesthetics create warning", { }) test_that("invalid aesthetics throws errors", { - p <- ggplot(mtcars) + geom_point(aes(disp, mpg, fill = data)) - expect_snapshot_error(ggplot_build(p)) - p <- ggplot(mtcars) + geom_point(aes(disp, mpg, fill = after_stat(data))) - expect_snapshot_error(ggplot_build(p)) + # We want to test error and ignore the scale search message + suppressMessages({ + p <- ggplot(mtcars) + geom_point(aes(disp, mpg, fill = data)) + expect_snapshot_error(ggplot_build(p)) + p <- ggplot(mtcars) + geom_point(aes(disp, mpg, fill = after_stat(data))) + expect_snapshot_error(ggplot_build(p)) + }) }) test_that("unknown NULL aesthetic doesn't create warning (#1909)", { @@ -57,8 +60,12 @@ test_that("missing aesthetics trigger informative error", { test_that("function aesthetics are wrapped with after_stat()", { df <- data_frame(x = 1:10) - expect_snapshot_error( - ggplot_build(ggplot(df, aes(colour = density, fill = density)) + geom_point()) + suppressMessages( + expect_snapshot_error( + ggplot_build( + ggplot(df, aes(colour = density, fill = density)) + geom_point() + ) + ) ) }) diff --git a/tests/testthat/test-stat-bin.R b/tests/testthat/test-stat-bin.R index 24aa21ec6a..d15a19fcff 100644 --- a/tests/testthat/test-stat-bin.R +++ b/tests/testthat/test-stat-bin.R @@ -9,11 +9,11 @@ test_that("stat_bin throws error when wrong combination of aesthetic is present" }) test_that("stat_bin works in both directions", { - p <- ggplot(mpg, aes(hwy)) + stat_bin() + p <- ggplot(mpg, aes(hwy)) + stat_bin(bins = 30) x <- layer_data(p) expect_false(x$flipped_aes[1]) - p <- ggplot(mpg, aes(y = hwy)) + stat_bin() + p <- ggplot(mpg, aes(y = hwy)) + stat_bin(bins = 30) y <- layer_data(p) expect_true(y$flipped_aes[1]) @@ -81,7 +81,7 @@ test_that("breaks are transformed by the scale", { test_that("geom_histogram() can be drawn over a 0-width range (#3043)", { df <- data_frame(x = rep(1, 100)) - out <- layer_data(ggplot(df, aes(x)) + geom_histogram()) + out <- layer_data(ggplot(df, aes(x)) + geom_histogram(bins = 30)) expect_equal(nrow(out), 1) expect_equal(out$xmin, 0.95) diff --git a/tests/testthat/test-utilities-checks.R b/tests/testthat/test-utilities-checks.R index 04dbd79f52..0619ccc707 100644 --- a/tests/testthat/test-utilities-checks.R +++ b/tests/testthat/test-utilities-checks.R @@ -2,7 +2,8 @@ test_that("check_device checks R versions correctly", { # Most widely supported device - withr::local_pdf() + file <- withr::local_tempfile(fileext = ".pdf") + withr::local_pdf(file) # R 4.0.0 doesn't support any new features with_mocked_bindings( @@ -45,7 +46,8 @@ test_that("check_device finds device capabilities", { getRversion() < "4.2.0", "R version < 4.2.0 does doesn't have proper `dev.capabilities()`." ) - withr::local_pdf() + file <- withr::local_tempfile(fileext = ".pdf") + withr::local_pdf(file) with_mocked_bindings( dev.capabilities = function() list(clippingPaths = TRUE), expect_true(check_device("clippingPaths")), From 15bde2fd5616d86838648992cb2b22b53bae95db Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Wed, 6 Dec 2023 12:18:14 +0100 Subject: [PATCH 3/4] Enable horizontal margins on (sub)title/caption (#5545) * enable x-margins * add news bullet --- NEWS.md | 3 +++ R/plot-build.R | 15 ++++++++++++--- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/NEWS.md b/NEWS.md index 992d5cc395..cabdc6940b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # ggplot2 (development version) +* 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) diff --git a/R/plot-build.R b/R/plot-build.R index 7fa0a89be3..51208d20dd 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -265,15 +265,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 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 4/4] 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 + ) +})