Refactor applying defaults in geom_sf() (#5834)

* add test for mixed geometry types

* allow custom defaults in `Geom$use_defaults()`

* Implement `GeomSf$use_defaults()`

* trim default setting in `sf_grob()`

* use `defer()` in case test fails

* add news bullet

Author: teunbrand

NEWS.md

@@ -1,5 +1,7 @@
 # ggplot2 (development version)
 
+* (Internal) Applying defaults in `geom_sf()` has moved from the internal 
+  `sf_grob()` to `GeomSf$use_defaults()` (@teunbrand).
 * `facet_wrap()` has new options for the `dir` argument to more precisely
   control panel directions (@teunbrand, #5212)
 * Prevented `facet_wrap(..., drop = FALSE)` from throwing spurious errors when

R/geom-.R

@@ -114,8 +114,8 @@ Geom <- ggproto("Geom",
   setup_data = function(data, params) data,
 
   # Combine data with defaults and set aesthetics from parameters
-  use_defaults = function(self, data, params = list(), modifiers = aes()) {
-    default_aes <- self$default_aes
+  use_defaults = function(self, data, params = list(), modifiers = aes(), default_aes = NULL) {
+    default_aes <- default_aes %||% self$default_aes
 
     # Inherit size as linewidth if no linewidth aesthetic and param exist
     if (self$rename_size && is.null(data$linewidth) && is.null(params$linewidth)) {

R/geom-sf.R

@@ -131,6 +131,63 @@ GeomSf <- ggproto("GeomSf", Geom,
     stroke = 0.5
   ),
 
+  use_defaults = function(self, data, params = list(), modifiers = aes(), default_aes = NULL) {
+    data <- ggproto_parent(Geom, self)$use_defaults(data, params, modifiers, default_aes)
+    # Early exit for e.g. legend data that don't have geometry columns
+    if (!"geometry" %in% names(data)) {
+      return(data)
+    }
+
+    # Devise splitting index for geometry types
+    type <- sf_types[sf::st_geometry_type(data$geometry)]
+    type <- factor(type, c("point", "line", "other", "collection"))
+    index <- split(seq_len(nrow(data)), type)
+
+    # Initialise parts of the data
+    points <- lines <- others <- collections <- NULL
+
+    # Go through every part, applying different defaults
+    if (length(index$point) > 0) {
+      points <- GeomPoint$use_defaults(
+        vec_slice(data, index$point),
+        params, modifiers
+      )
+    }
+    if (length(index$line) > 0) {
+      lines <- GeomLine$use_defaults(
+        vec_slice(data, index$line),
+        params, modifiers
+      )
+    }
+    other_default <- modify_list(
+      GeomPolygon$default_aes,
+      list(fill = "grey90", colour = "grey35", linewidth = 0.2)
+    )
+    if (length(index$other) > 0) {
+      others <- GeomPolygon$use_defaults(
+        vec_slice(data, index$other),
+        params, modifiers,
+        default_aes = other_default
+      )
+    }
+    if (length(index$collection) > 0) {
+      modified <- rename(
+        GeomPoint$default_aes,
+        c(fill = "point_fill")
+      )
+      modified <- modify_list(other_default, modified)
+      collections <- Geom$use_defaults(
+        vec_slice(data, index$collection),
+        params, modifiers,
+        default_aes = modified
+      )
+    }
+
+    # Recombine data in original order
+    data <- vec_c(points, lines, others, collections)
+    vec_slice(data, order(unlist(index)))
+  },
+
   draw_panel = function(self, data, panel_params, coord, legend = NULL,
                         lineend = "butt", linejoin = "round", linemitre = 10,
                         arrow = NULL, na.rm = TRUE) {
@@ -189,36 +246,24 @@ sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10,
     type_ind <- type_ind[!remove]
     is_collection <- is_collection[!remove]
   }
-  defaults <- list(
-    GeomPoint$default_aes,
-    GeomLine$default_aes,
-    modify_list(GeomPolygon$default_aes, list(fill = "grey90", colour = "grey35", linewidth = 0.2))
-  )
-  defaults[[4]] <- modify_list(
-    defaults[[3]],
-    rename(GeomPoint$default_aes, c(size = "point_size", fill = "point_fill"))
-  )
-  default_names <- unique0(unlist(lapply(defaults, names)))
-  defaults <- lapply(setNames(default_names, default_names), function(n) {
-    unlist(lapply(defaults, function(def) def[[n]] %||% NA))
-  })
-  alpha <- x$alpha %||% defaults$alpha[type_ind]
-  col <- x$colour %||% defaults$colour[type_ind]
+
+  alpha <- x$alpha %||% NA
+  fill <- fill_alpha(x$fill %||% NA, alpha)
+  col <- x$colour %||% NA
   col[is_point | is_line] <- alpha(col[is_point | is_line], alpha[is_point | is_line])
-  fill <- x$fill %||% defaults$fill[type_ind]
-  fill <- fill_alpha(fill, alpha)
-  size <- x$size %||% defaults$size[type_ind]
-  linewidth <- x$linewidth %||% defaults$linewidth[type_ind]
+
+  size <- x$size %||% 0.5
+  linewidth <- x$linewidth %||% 0.5
   point_size <- ifelse(
     is_collection,
-    x$size %||% defaults$point_size[type_ind],
+    x$size,
     ifelse(is_point, size, linewidth)
   )
-  stroke <- (x$stroke %||% defaults$stroke[1]) * .stroke / 2
+  stroke <- (x$stroke %||% 0) * .stroke / 2
   fontsize <- point_size * .pt + stroke
   lwd <- ifelse(is_point, stroke, linewidth * .pt)
-  pch <- x$shape %||% defaults$shape[type_ind]
-  lty <- x$linetype %||% defaults$linetype[type_ind]
+  pch <- x$shape
+  lty <- x$linetype
   gp <- gpar(
     col = col, fill = fill, fontsize = fontsize, lwd = lwd, lty = lty,
     lineend = lineend, linejoin = linejoin, linemitre = linemitre

tests/testthat/_snaps/geom-sf/mixed-geometry-types.svg

@@ -196,6 +196,43 @@ test_that("geom_sf draws correctly", {
   )
 })
 
+test_that("geom_sf uses combinations of geometry correctly", {
+  skip_if_not_installed("sf")
+
+  t <- seq(0, 2 *pi, length.out = 10)
+  data <- sf::st_sf(sf::st_sfc(
+    sf::st_multipoint(cbind(1:2, 3:4)),
+    sf::st_multilinestring(list(
+      cbind(c(1, 1.8), c(3.8, 3)),
+      cbind(c(1.2, 2), c(4, 3.2))
+    )),
+    sf::st_polygon(list(
+      cbind(cos(t), zapsmall(sin(t))),
+      cbind(cos(t), zapsmall(sin(t))) + 5
+    )),
+    sf::st_geometrycollection(x = list(
+      sf::st_point(x = c(3, 2)),
+      sf::st_linestring(cbind(c(2, 4, 4), c(1, 1, 3)))
+    )),
+    sf::st_linestring(x = cbind(c(2, 6), c(-1, 3))),
+    sf::st_point(c(5, 0))
+  ))
+
+  update_geom_defaults("point", list(colour = "blue"))
+  update_geom_defaults("line", list(colour = "red"))
+  # Note: polygon defaults are mostly ignored or overridden
+
+  withr::defer({
+    update_geom_defaults("point", NULL)
+    update_geom_defaults("line",  NULL)
+  })
+
+  expect_doppelganger(
+    "mixed geometry types",
+    ggplot(data) + geom_sf()
+  )
+})
+
 test_that("geom_sf_text() and geom_sf_label() draws correctly", {
   skip_if_not_installed("sf")
   if (packageVersion("sf") < "0.5.3") skip("Need sf 0.5.3")