From df0e150249474f1d465a45b01ad16a6771091cc8 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 28 Jan 2025 14:20:45 +0100 Subject: [PATCH] =?UTF-8?q?=E2=9C=A8=20Point=20and=20polygon=20theme=20ele?= =?UTF-8?q?ments=20(#6249)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * `translate_shape_string()` deals with non-character input * new element constructors * document new elements * add `element_grob()` methods * include `point` and `polygon` in theme * include template in default themes * :technologist: deal with `pathGrob()`'s id-logic. * add tests * add news bullet --- NAMESPACE | 4 + NEWS.md | 2 + R/geom-point.R | 11 +-- R/geom-sf.R | 4 +- R/legend-draw.R | 6 +- R/theme-defaults.R | 22 +++++ R/theme-elements.R | 84 +++++++++++++++++-- R/theme.R | 4 + man/element.Rd | 37 ++++++-- man/theme.Rd | 6 ++ man/translate_shape_string.Rd | 3 +- .../testthat/_snaps/theme/point-elements.svg | 27 ++++++ .../_snaps/theme/polygon-elements.svg | 24 ++++++ tests/testthat/test-theme.R | 41 +++++++++ 14 files changed, 247 insertions(+), 28 deletions(-) create mode 100644 tests/testthat/_snaps/theme/point-elements.svg create mode 100644 tests/testthat/_snaps/theme/polygon-elements.svg diff --git a/NAMESPACE b/NAMESPACE index 690b9fb0ed..b58765ecc1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,6 +20,8 @@ S3method(c,mapped_discrete) S3method(drawDetails,zeroGrob) S3method(element_grob,element_blank) S3method(element_grob,element_line) +S3method(element_grob,element_point) +S3method(element_grob,element_polygon) S3method(element_grob,element_rect) S3method(element_grob,element_text) S3method(format,ggproto) @@ -346,6 +348,8 @@ export(element_blank) export(element_geom) export(element_grob) export(element_line) +export(element_point) +export(element_polygon) export(element_rect) export(element_render) export(element_text) diff --git a/NEWS.md b/NEWS.md index c8abcc17de..5497358548 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* New `element_point()` and `element_polygon()` that can be given to + `theme(point, polygon)` as an extension point (@teunbrand, #6248). * Turned off fallback for `size` to `linewidth` translation in `geom_bar()`/`geom_col()` (#4848). * `coord_radial()` now displays no axis instead of throwing an error when diff --git a/R/geom-point.R b/R/geom-point.R index bf73cf8749..47f3fc6fc2 100644 --- a/R/geom-point.R +++ b/R/geom-point.R @@ -148,10 +148,7 @@ GeomPoint <- ggproto("GeomPoint", Geom, ), draw_panel = function(self, data, panel_params, coord, na.rm = FALSE) { - if (is.character(data$shape)) { - data$shape <- translate_shape_string(data$shape) - } - + data$shape <- translate_shape_string(data$shape) coords <- coord$transform(data, panel_params) ggname("geom_point", pointsGrob( @@ -176,7 +173,8 @@ GeomPoint <- ggproto("GeomPoint", Geom, #' given as a character vector into integers that are interpreted by the #' grid system. #' -#' @param shape_string A character vector giving point shapes. +#' @param shape_string A character vector giving point shapes. Non-character +#' input will be returned. #' #' @return An integer vector with translated shapes. #' @export @@ -188,6 +186,9 @@ GeomPoint <- ggproto("GeomPoint", Geom, #' # Strings with 1 or less characters are interpreted as symbols #' translate_shape_string(c("a", "b", "?")) translate_shape_string <- function(shape_string) { + if (!is.character(shape_string)) { + return(shape_string) + } # strings of length 0 or 1 are interpreted as symbols by grid if (nchar(shape_string[1]) <= 1) { return(shape_string) diff --git a/R/geom-sf.R b/R/geom-sf.R index 4b61300108..78c543a50d 100644 --- a/R/geom-sf.R +++ b/R/geom-sf.R @@ -209,9 +209,7 @@ GeomSf <- ggproto("GeomSf", Geom, if (!inherits(coord, "CoordSf")) { cli::cli_abort("{.fn {snake_class(self)}} can only be used with {.fn coord_sf}.") } - if (is.character(data$shape)) { - data$shape <- translate_shape_string(data$shape) - } + data$shape <- translate_shape_string(data$shape) data <- coord$transform(data, panel_params) diff --git a/R/legend-draw.R b/R/legend-draw.R index eb33cc24d7..533e9e111f 100644 --- a/R/legend-draw.R +++ b/R/legend-draw.R @@ -24,11 +24,7 @@ NULL #' @export #' @rdname draw_key draw_key_point <- function(data, params, size) { - if (is.null(data$shape)) { - data$shape <- 19 - } else if (is.character(data$shape)) { - data$shape <- translate_shape_string(data$shape) - } + data$shape <- translate_shape_string(data$shape %||% 19) # NULL means the default stroke size, and NA means no stroke. pointsGrob(0.5, 0.5, diff --git a/R/theme-defaults.R b/R/theme-defaults.R index e6efd2a783..7fe9742f5e 100644 --- a/R/theme-defaults.R +++ b/R/theme-defaults.R @@ -145,6 +145,17 @@ theme_grey <- function(base_size = 11, base_family = "", spacing = unit(half_line, "pt"), margins = margin_auto(half_line), + point = element_point( + colour = ink, shape = 19, fill = paper, + size = (base_size / 11) * 1.5, + stroke = base_line_size + ), + + polygon = element_polygon( + fill = paper, colour = ink, + linewidth = base_rect_size, linetype = 1 + ), + geom = element_geom( ink = ink, paper = paper, accent = "#3366FF", linewidth = base_line_size, borderwidth = base_line_size, @@ -549,6 +560,8 @@ theme_void <- function(base_size = 11, base_family = "", t <- theme( line = element_blank(), rect = element_blank(), + polygon = element_blank(), + point = element_blank(), text = element_text( family = base_family, face = "plain", colour = ink, size = base_size, @@ -639,6 +652,15 @@ theme_test <- function(base_size = 11, base_family = "", lineheight = 0.9, hjust = 0.5, vjust = 0.5, angle = 0, margin = margin(), debug = FALSE ), + point = element_point( + colour = ink, shape = 19, fill = paper, + size = (base_size / 11) * 1.5, + stroke = base_line_size + ), + polygon = element_polygon( + fill = paper, colour = ink, + linewidth = base_rect_size, linetype = 1 + ), title = element_text(family = header_family), spacing = unit(half_line, "pt"), margins = margin_auto(half_line), diff --git a/R/theme-elements.R b/R/theme-elements.R index 7d3ceb47dd..c3b6ded319 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -8,6 +8,8 @@ #' - `element_rect()`: borders and backgrounds. #' - `element_line()`: lines. #' - `element_text()`: text. +#' - `element_polygon()`: polygons. +#' - `element_point()`: points. #' - `element_geom()`: defaults for drawing layers. #' #' `rel()` is used to specify sizes relative to the parent, @@ -18,8 +20,13 @@ #' of the fill. #' @param colour,color Line/border colour. Color is an alias for colour. #' `alpha()` can be used to set the transparency of the colour. -#' @param linewidth,borderwidth Line/border size in mm. -#' @param size,fontsize text size in pts. +#' @param linewidth,borderwidth,stroke Line/border size in mm. +#' @param size,fontsize,pointsize text size in pts, point size in mm. +#' @param linetype,bordertype Line type for lines and borders respectively. An +#' integer (0:8), a name (blank, solid, dashed, dotted, dotdash, longdash, +#' twodash), or a string with an even number (up to eight) of hexadecimal +#' digits which give the lengths in consecutive positions in the string. +#' @param shape,pointshape Shape for points (1-25). #' @param arrow.fill Fill colour for arrows. #' @param inherit.blank Should this element inherit the existence of an #' `element_blank` among its parents? If `TRUE` the existence of @@ -27,6 +34,10 @@ #' well. If `FALSE` any blank parent element will be ignored when #' calculating final element state. #' @return An S3 object of class `element`, `rel`, or `margin`. +#' @details +#' The `element_polygon()` and `element_point()` functions are not rendered +#' in standard plots and just serve as extension points. +#' #' @examples #' # A standard plot #' plot <- ggplot(mpg, aes(displ, hwy)) + geom_point() @@ -97,10 +108,6 @@ element_rect <- function(fill = NULL, colour = NULL, linewidth = NULL, #' @export #' @rdname element -#' @param linetype,bordertype Line type for lines and borders respectively. An -#' integer (0:8), a name (blank, solid, dashed, dotted, dotdash, longdash, -#' twodash), or a string with an even number (up to eight) of hexadecimal -#' digits which give the lengths in consecutive positions in the string. #' @param lineend Line end Line end style (round, butt, square) #' @param arrow Arrow specification, as created by [grid::arrow()] element_line <- function(colour = NULL, linewidth = NULL, linetype = NULL, @@ -164,11 +171,36 @@ element_text <- function(family = NULL, face = NULL, colour = NULL, ) } +#' @export +#' @rdname element +element_polygon <- function(fill = NULL, colour = NULL, linewidth = NULL, + linetype = NULL, color = NULL, + inherit.blank = FALSE) { + structure( + list( + fill = fill, colour = color %||% colour, linewidth = linewidth, + linetype = linetype, inherit.blank = inherit.blank + ), + class = c("element_polygon", "element") + ) +} + +#' @export +#' @rdname element +element_point <- function(colour = NULL, shape = NULL, size = NULL, fill = NULL, + stroke = NULL, color = NULL, inherit.blank = FALSE) { + structure( + list( + colour = color %||% colour, fill = fill, shape = shape, size = size, + stroke = stroke, inherit.blank = inherit.blank + ), + class = c("element_point", "element") + ) +} + #' @param ink Foreground colour. #' @param paper Background colour. #' @param accent Accent colour. -#' @param pointsize Size for points in mm. -#' @param pointshape Shape for points (1-25). #' @export #' @rdname element element_geom <- function( @@ -357,6 +389,40 @@ element_grob.element_line <- function(element, x = 0:1, y = 0:1, ) } +#' @export +element_grob.element_polygon <- function(element, x = c(0, 0.5, 1, 0.5), + y = c(0.5, 1, 0.5, 0), fill = NULL, + colour = NULL, linewidth = NULL, + linetype = NULL, ..., + id = NULL, id.lengths = NULL, + pathId = NULL, pathId.lengths = NULL) { + + gp <- gg_par(lwd = linewidth, col = colour, fill = fill, lty = linetype) + element_gp <- gg_par(lwd = element$linewidth, col = element$colour, + fill = element$fill, lty = element$linetype) + pathGrob( + x = x, y = y, gp = modify_list(element_gp, gp), ..., + # We swap the id logic so that `id` is always the (super)group id + # (consistent with `polygonGrob()`) and `pathId` always the subgroup id. + pathId = id, pathId.lengths = id.lengths, + id = pathId, id.lengths = pathId.lengths + ) +} + +#' @export +element_grob.element_point <- function(element, x = 0.5, y = 0.5, colour = NULL, + shape = NULL, fill = NULL, size = NULL, + stroke = NULL, ..., + default.units = "npc") { + + gp <- gg_par(col = colour, fill = fill, pointsize = size, stroke = stroke) + element_gp <- gg_par(col = element$colour, fill = element$fill, + pointsize = element$size, stroke = element$stroke) + shape <- translate_shape_string(shape %||% element$shape %||% 19) + pointsGrob(x = x, y = y, pch = shape, gp = modify_list(element_gp, gp), + default.units = default.units, ...) +} + #' Define and register new theme elements #' #' The underlying structure of a ggplot2 theme is defined via the element tree, which @@ -532,6 +598,8 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { line = el_def("element_line"), rect = el_def("element_rect"), text = el_def("element_text"), + point = el_def("element_point"), + polygon = el_def("element_polygon"), geom = el_def("element_geom"), title = el_def("element_text", "text"), spacing = el_def("unit"), diff --git a/R/theme.R b/R/theme.R index bf65c565a9..dfe986fc62 100644 --- a/R/theme.R +++ b/R/theme.R @@ -25,6 +25,8 @@ #' @param text all text elements ([element_text()]) #' @param title all title elements: plot, axes, legends ([element_text()]; #' inherits from `text`) +#' @param point all point elements ([element_point()]) +#' @param polygon all polygon elements ([element_polygon()]) #' @param geom defaults for geoms ([element_geom()]) #' @param spacing all spacings ([`unit()`][grid::unit]) #' @param margins all margins ([margin()]) @@ -323,6 +325,8 @@ theme <- function(..., rect, text, title, + point, + polygon, geom, spacing, margins, diff --git a/man/element.Rd b/man/element.Rd index 041bf794f5..99e56f0e94 100644 --- a/man/element.Rd +++ b/man/element.Rd @@ -5,6 +5,8 @@ \alias{element_rect} \alias{element_line} \alias{element_text} +\alias{element_polygon} +\alias{element_point} \alias{element_geom} \alias{rel} \alias{margin} @@ -51,6 +53,25 @@ element_text( inherit.blank = FALSE ) +element_polygon( + fill = NULL, + colour = NULL, + linewidth = NULL, + linetype = NULL, + color = NULL, + inherit.blank = FALSE +) + +element_point( + colour = NULL, + shape = NULL, + size = NULL, + fill = NULL, + stroke = NULL, + color = NULL, + inherit.blank = FALSE +) + element_geom( ink = NULL, paper = NULL, @@ -80,7 +101,7 @@ of the fill.} \item{colour, color}{Line/border colour. Color is an alias for colour. \code{alpha()} can be used to set the transparency of the colour.} -\item{linewidth, borderwidth}{Line/border size in mm.} +\item{linewidth, borderwidth, stroke}{Line/border size in mm.} \item{linetype, bordertype}{Line type for lines and borders respectively. An integer (0:8), a name (blank, solid, dashed, dotted, dotdash, longdash, @@ -93,7 +114,7 @@ a blank element among its parents will cause this element to be blank as well. If \code{FALSE} any blank parent element will be ignored when calculating final element state.} -\item{size, fontsize}{text size in pts.} +\item{size, fontsize, pointsize}{text size in pts, point size in mm.} \item{lineend}{Line end Line end style (round, butt, square)} @@ -121,16 +142,14 @@ side of the text facing towards the center of the plot.} rectangle behind the complete text area, and a point where each label is anchored.} +\item{shape, pointshape}{Shape for points (1-25).} + \item{ink}{Foreground colour.} \item{paper}{Background colour.} \item{accent}{Accent colour.} -\item{pointsize}{Size for points in mm.} - -\item{pointshape}{Shape for points (1-25).} - \item{x}{A single number specifying size relative to parent element.} \item{t, r, b, l}{Dimensions of each margin. (To remember order, think trouble).} @@ -149,6 +168,8 @@ specify the display of how non-data components of the plot are drawn. \item \code{element_rect()}: borders and backgrounds. \item \code{element_line()}: lines. \item \code{element_text()}: text. +\item \code{element_polygon()}: polygons. +\item \code{element_point()}: points. \item \code{element_geom()}: defaults for drawing layers. } @@ -156,6 +177,10 @@ specify the display of how non-data components of the plot are drawn. \code{margin()}, \code{margin_part()} and \code{margin_auto()} are all used to specify the margins of elements. } +\details{ +The \code{element_polygon()} and \code{element_point()} functions are not rendered +in standard plots and just serve as extension points. +} \examples{ # A standard plot plot <- ggplot(mpg, aes(displ, hwy)) + geom_point() diff --git a/man/theme.Rd b/man/theme.Rd index 0a4941266e..2766a3f8ca 100644 --- a/man/theme.Rd +++ b/man/theme.Rd @@ -10,6 +10,8 @@ theme( rect, text, title, + point, + polygon, geom, spacing, margins, @@ -165,6 +167,10 @@ these should also be defined in the \verb{element tree} argument. \link[rlang:sp \item{title}{all title elements: plot, axes, legends (\code{\link[=element_text]{element_text()}}; inherits from \code{text})} +\item{point}{all point elements (\code{\link[=element_point]{element_point()}})} + +\item{polygon}{all polygon elements (\code{\link[=element_polygon]{element_polygon()}})} + \item{geom}{defaults for geoms (\code{\link[=element_geom]{element_geom()}})} \item{spacing}{all spacings (\code{\link[grid:unit]{unit()}})} diff --git a/man/translate_shape_string.Rd b/man/translate_shape_string.Rd index f6d205cf79..cbbcad05a7 100644 --- a/man/translate_shape_string.Rd +++ b/man/translate_shape_string.Rd @@ -7,7 +7,8 @@ translate_shape_string(shape_string) } \arguments{ -\item{shape_string}{A character vector giving point shapes.} +\item{shape_string}{A character vector giving point shapes. Non-character +input will be returned.} } \value{ An integer vector with translated shapes. diff --git a/tests/testthat/_snaps/theme/point-elements.svg b/tests/testthat/_snaps/theme/point-elements.svg new file mode 100644 index 0000000000..f810f35c3b --- /dev/null +++ b/tests/testthat/_snaps/theme/point-elements.svg @@ -0,0 +1,27 @@ + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/theme/polygon-elements.svg b/tests/testthat/_snaps/theme/polygon-elements.svg new file mode 100644 index 0000000000..e6e0de8c72 --- /dev/null +++ b/tests/testthat/_snaps/theme/polygon-elements.svg @@ -0,0 +1,24 @@ + + + + + + + + + + + + + + + + diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index eba47a0c75..8d74b4038f 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -712,6 +712,47 @@ test_that("margin_part() mechanics work as expected", { # Visual tests ------------------------------------------------------------ +test_that("element_polygon() can render a grob", { + + t <- theme_gray() + theme(polygon = element_polygon(fill = "orchid")) + e <- calc_element("polygon", t) + g <- element_grob( + e, + x = c(0, 0.5, 1, 0.5, 0.15, 0.85, 0.85, 0.15), + y = c(0.5, 0, 0.5, 1, 0.15, 0.15, 0.85, 0.85), + id = c(1, 1, 1, 1, 2, 2, 2, 2), + colour = c("orange", "limegreen") + ) + + expect_s3_class(g, "pathgrob") + expect_equal(g$gp$fill, "orchid") + + expect_doppelganger( + "polygon elements", + function() {grid.newpage(); grid.draw(g)} + ) +}) + +test_that("element_point() can render a grob", { + + t <- theme_gray() + theme(point = element_point(shape = 21, size = 5)) + e <- calc_element("point", t) + g <- element_grob( + e, + x = seq(0.1, 0.9, length.out = 5), + y = seq(0.9, 0.1, length.out = 5), + fill = c("orange", "limegreen", "orchid", "turquoise", "grey") + ) + + expect_s3_class(g, "points") + expect_equal(g$pch, 21) + + expect_doppelganger( + "point elements", + function() {grid.newpage(); grid.draw(g)} + ) +}) + test_that("aspect ratio is honored", { df <- cbind(data_frame(x = 1:8, y = 1:8, f = gl(2,4)), expand.grid(f1 = 1:2, f2 = 1:2, rep = 1:2)) p <- ggplot(df, aes(x, y)) +