✨ Point and polygon theme elements (#6249)

* `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 * 🧑‍💻 deal with `pathGrob()`'s id-logic. * add tests * add news bullet
tidyverse · Jan 28, 2025 · df0e150 · df0e150
1 parent df315af
commit df0e150
Show file tree

Hide file tree

Showing 14 changed files with 247 additions and 28 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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,15 +20,24 @@
 #'   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
 #'   a blank element among its parents will cause this element to be blank as
 #'   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
@@ -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
diff --git a/man/theme.Rd b/man/theme.Rd