Refactor applying defaults in geom_sf()

NEWS.md

@@ -1,6 +1,8 @@
 
 # ggplot2 (development version)
 
+* (Internal) Applying defaults in `geom_sf()` has moved from the internal 
+ `sf_grob()` to `GeomSf$use_defaults()` (@teunbrand).
 * When facets coerce the faceting variables to factors, the 'ordered' class
  is dropped (@teunbrand, #5666).
 * `update_geom_defaults()` and `update_stat_defaults()` have a reset mechanism

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/test-geom-sf.R

@@ -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")