From 8e63882c3c36259785baac0eed5d51525bc40f70 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 29 Apr 2024 11:12:38 +0200 Subject: [PATCH] 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 --- NEWS.md | 2 + R/geom-.R | 4 +- R/geom-sf.R | 91 ++++++++++++++----- .../_snaps/geom-sf/mixed-geometry-types.svg | 85 +++++++++++++++++ tests/testthat/test-geom-sf.R | 37 ++++++++ 5 files changed, 194 insertions(+), 25 deletions(-) create mode 100644 tests/testthat/_snaps/geom-sf/mixed-geometry-types.svg diff --git a/NEWS.md b/NEWS.md index e4361c5556..070c74dd40 100644 --- a/NEWS.md +++ b/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 diff --git a/R/geom-.R b/R/geom-.R index c1967a89c1..ab4e1ed1b7 100644 --- a/R/geom-.R +++ b/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)) { diff --git a/R/geom-sf.R b/R/geom-sf.R index a8f70d7f4e..cdcadb1140 100644 --- a/R/geom-sf.R +++ b/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 diff --git a/tests/testthat/_snaps/geom-sf/mixed-geometry-types.svg b/tests/testthat/_snaps/geom-sf/mixed-geometry-types.svg new file mode 100644 index 0000000000..c8dc5b6922 --- /dev/null +++ b/tests/testthat/_snaps/geom-sf/mixed-geometry-types.svg @@ -0,0 +1,85 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-1 + 0 + 1 + 2 + 3 + 4 + 5 + 6 + + + + + + + + + + + + + + + + +-1 + 0 + 1 + 2 + 3 + 4 + 5 + 6 +mixed geometry types + + diff --git a/tests/testthat/test-geom-sf.R b/tests/testthat/test-geom-sf.R index af5d6bdb9d..1db38a1fff 100644 --- a/tests/testthat/test-geom-sf.R +++ b/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")