From d3957511a918ce0022b4f34196e567cd33ebe9cd Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 23 May 2024 09:10:26 +0200 Subject: [PATCH 1/8] use ellipses in `use_defaults()`/`compute_geom_2()` --- R/geom-.R | 2 +- R/layer.R | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/geom-.R b/R/geom-.R index f538cf0bb6..c3da9be244 100644 --- a/R/geom-.R +++ b/R/geom-.R @@ -114,7 +114,7 @@ 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 = NULL) { + 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 diff --git a/R/layer.R b/R/layer.R index 88b6a9b026..8b4621bde2 100644 --- a/R/layer.R +++ b/R/layer.R @@ -438,14 +438,14 @@ Layer <- ggproto("Layer", NULL, self$position$compute_layer(data, params, layout) }, - compute_geom_2 = function(self, data) { + compute_geom_2 = function(self, data, params = self$aes_params, ...) { # Combine aesthetics, defaults, & params if (empty(data)) return(data) aesthetics <- self$computed_mapping modifiers <- aesthetics[is_scaled_aes(aesthetics) | is_staged_aes(aesthetics)] - self$geom$use_defaults(data, self$aes_params, modifiers) + self$geom$use_defaults(data, params, modifiers, ...) }, finish_statistics = function(self, data) { From c4ce907226421436405604f130d04da1b6a12b56 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 23 May 2024 09:11:30 +0200 Subject: [PATCH 2/8] return empty keys as-is --- R/guide-legend.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/guide-legend.R b/R/guide-legend.R index 2ef01fbae9..1d84ff0ed3 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -225,6 +225,10 @@ GuideLegend <- ggproto( get_layer_key = function(params, layers, data) { + if (nrow(params$key) < 1) { + return(params) + } + decor <- Map(layer = layers, df = data, f = function(layer, df) { matched_aes <- matched_aes(layer, params) From 29fb5a4d8b6c43527acdb021d9e21330ac21eb01 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 23 May 2024 09:24:06 +0200 Subject: [PATCH 3/8] let `compute_geom_2()` handle populating defaults --- R/guide-legend.R | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/R/guide-legend.R b/R/guide-legend.R index 1d84ff0ed3..7f4fb1b127 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -225,35 +225,35 @@ GuideLegend <- ggproto( get_layer_key = function(params, layers, data) { + # Return empty guides as-is if (nrow(params$key) < 1) { return(params) } decor <- Map(layer = layers, df = data, f = function(layer, df) { + # Subset key to the column with aesthetic matching the layer matched_aes <- matched_aes(layer, params) + key <- params$key[matched_aes] - if (length(matched_aes) > 0) { - # Filter out aesthetics that can't be applied to the legend - n <- lengths(layer$aes_params, use.names = FALSE) - layer_params <- layer$aes_params[n == 1] + # Filter static aesthetics to those with single values + single_params <- lengths(layer$aes_params) == 1L + single_params <- layer$aes_params[single_params] - aesthetics <- layer$computed_mapping - is_modified <- is_scaled_aes(aesthetics) | is_staged_aes(aesthetics) - modifiers <- aesthetics[is_modified] + # Use layer to populate defaults + key <- layer$compute_geom_2(key, single_params) - data <- layer$geom$use_defaults(params$key[matched_aes], layer_params, modifiers) - data$.draw <- keep_key_data(params$key, df, matched_aes, layer$show.legend) - } else { - reps <- rep(1, nrow(params$key)) - data <- layer$geom$use_defaults(NULL, layer$aes_params)[reps, ] + # Filter non-existing levels + if (length(matched_aes) > 0) { + key$.draw <- keep_key_data(params$key, df, matched_aes, layer$show.legend) } - data <- modify_list(data, params$override.aes) + # Apply overrides + key <- modify_list(key, params$override.aes) list( draw_key = layer$geom$draw_key, - data = data, + data = key, params = c(layer$computed_geom_params, layer$computed_stat_params) ) }) From 9c362230a69908bca223f69ebc1b5d73e23b7eb4 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 23 May 2024 10:09:43 +0200 Subject: [PATCH 4/8] ensure legends can be rendered for unrelated geoms --- R/guide-legend.R | 1 + tests/testthat/test-guides.R | 19 +++++++++++++++++++ 2 files changed, 20 insertions(+) diff --git a/R/guide-legend.R b/R/guide-legend.R index 7f4fb1b127..95dba1cfa0 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -235,6 +235,7 @@ GuideLegend <- ggproto( # Subset key to the column with aesthetic matching the layer matched_aes <- matched_aes(layer, params) key <- params$key[matched_aes] + key$.id <- seq_len(nrow(key)) # Filter static aesthetics to those with single values single_params <- lengths(layer$aes_params) == 1L diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index 8d677dc1bf..a2e5ae918d 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -552,6 +552,25 @@ test_that("bins can be parsed by guides for all scale types", { ) }) +test_that("legends can be forced to display unrelated geoms", { + + df <- data.frame(x = 1:2) + + p <- ggplot(df, aes(x, x)) + + geom_tile(fill = "red", show.legend = TRUE) + + scale_colour_discrete( + limits = c("A", "B") + ) + + b <- ggplot_build(p) + legend <- b$plot$guides$params[[1]] + + expect_equal( + legend$decor[[1]]$data$fill, + c("red", "red") + ) +}) + # Visual tests ------------------------------------------------------------ test_that("axis guides are drawn correctly", { From ea34eae222fda023e81d0495e436fd2d0c533432 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 23 May 2024 10:10:51 +0200 Subject: [PATCH 5/8] add visual tests for geom_sf legend types --- .../_snaps/geom-sf/geom-sf-line-legend.svg | 82 +++++++++++++++++++ .../_snaps/geom-sf/geom-sf-point-legend.svg | 78 ++++++++++++++++++ .../_snaps/geom-sf/geom-sf-polygon-legend.svg | 82 +++++++++++++++++++ tests/testthat/test-geom-sf.R | 41 ++++++++++ 4 files changed, 283 insertions(+) create mode 100644 tests/testthat/_snaps/geom-sf/geom-sf-line-legend.svg create mode 100644 tests/testthat/_snaps/geom-sf/geom-sf-point-legend.svg create mode 100644 tests/testthat/_snaps/geom-sf/geom-sf-polygon-legend.svg diff --git a/tests/testthat/_snaps/geom-sf/geom-sf-line-legend.svg b/tests/testthat/_snaps/geom-sf/geom-sf-line-legend.svg new file mode 100644 index 0000000000..642a061bab --- /dev/null +++ b/tests/testthat/_snaps/geom-sf/geom-sf-line-legend.svg @@ -0,0 +1,82 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +3.0 +3.5 +4.0 +4.5 +5.0 +5.5 +6.0 + + + + + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +3.5 +4.0 + +col + + + + +bar +foo +geom_sf line legend + + diff --git a/tests/testthat/_snaps/geom-sf/geom-sf-point-legend.svg b/tests/testthat/_snaps/geom-sf/geom-sf-point-legend.svg new file mode 100644 index 0000000000..e92ba98f8e --- /dev/null +++ b/tests/testthat/_snaps/geom-sf/geom-sf-point-legend.svg @@ -0,0 +1,78 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +3.0 +3.2 +3.4 +3.6 +3.8 +4.0 + + + + + + + + + + + + +1.0 +1.2 +1.4 +1.6 +1.8 +2.0 + +col + + + + +bar +foo +geom_sf point legend + + diff --git a/tests/testthat/_snaps/geom-sf/geom-sf-polygon-legend.svg b/tests/testthat/_snaps/geom-sf/geom-sf-polygon-legend.svg new file mode 100644 index 0000000000..6eb5d587a8 --- /dev/null +++ b/tests/testthat/_snaps/geom-sf/geom-sf-polygon-legend.svg @@ -0,0 +1,82 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +3.0 +3.5 +4.0 +4.5 +5.0 +5.5 +6.0 + + + + + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +3.5 +4.0 + +col + + + + +bar +foo +geom_sf polygon legend + + diff --git a/tests/testthat/test-geom-sf.R b/tests/testthat/test-geom-sf.R index d79146ff73..cfc662f442 100644 --- a/tests/testthat/test-geom-sf.R +++ b/tests/testthat/test-geom-sf.R @@ -196,6 +196,47 @@ test_that("geom_sf draws correctly", { ) }) +test_that("geom_sf data type renders appropriate legends", { + skip_if_not_installed("sf") + p <- ggplot() + geom_sf(aes(colour = col)) + + # Point data + data <- sf::st_as_sf( + data.frame(lon = c(1, 2), lat = c(3, 4), col = c("foo", "bar")), + coords = c("lon", "lat") + ) + expect_doppelganger( + "geom_sf point legend", + p %+% data + ) + + # Line data + data <- sf::st_as_sf( + sf::st_sfc( + sf::st_linestring(x = cbind(1:2, 3:4)), + sf::st_linestring(x = cbind(3:4, 5:6)) + ), + col = c("foo", "bar") + ) + expect_doppelganger( + "geom_sf line legend", + p %+% data + ) + + # Polygon data + data <- sf::st_as_sf( + sf::st_sfc( + sf::st_polygon(list(cbind(c(1, 2, 2, 1), c(3, 3, 4, 3)))), + sf::st_polygon(list(cbind(c(3, 3, 4, 3), c(5, 6, 6, 5)))) + ), + col = c("foo", "bar") + ) + expect_doppelganger( + "geom_sf polygon legend", + p %+% data + ) +}) + test_that("geom_sf uses combinations of geometry correctly", { skip_if_not_installed("sf") From 66055ee5dd5a8848ad3b9d795e3ef78b05df34ed Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 23 May 2024 10:26:29 +0200 Subject: [PATCH 6/8] simplify sf legend type detection --- R/layer-sf.R | 39 ++++++++++++----------------------- tests/testthat/test-geom-sf.R | 9 +------- 2 files changed, 14 insertions(+), 34 deletions(-) diff --git a/R/layer-sf.R b/R/layer-sf.R index 4a1b8e6512..ad085a8e8f 100644 --- a/R/layer-sf.R +++ b/R/layer-sf.R @@ -38,10 +38,6 @@ layer_sf <- function(geom = NULL, stat = NULL, LayerSf <- ggproto("LayerSf", Layer, legend_key_type = NULL, - # This field carry state throughout rendering but will always be - # calculated before use - computed_legend_key_type = NULL, - setup_layer = function(self, data, plot) { # process generic layer setup first data <- ggproto_parent(Layer, self)$setup_layer(data, plot) @@ -56,34 +52,22 @@ LayerSf <- ggproto("LayerSf", Layer, self$computed_mapping$geometry <- sym(geometry_col) } } - - # automatically determine the legend type - if (is.null(self$legend_key_type)) { - # first, set default value in case downstream tests fail - self$computed_legend_key_type <- "polygon" - - # now check if the type should not be polygon - if (!is.null(self$computed_mapping$geometry) && quo_is_symbol(self$computed_mapping$geometry)) { - geometry_column <- as_name(self$computed_mapping$geometry) - if (inherits(data[[geometry_column]], "sfc")) { - sf_type <- detect_sf_type(data[[geometry_column]]) - if (sf_type == "point") { - self$computed_legend_key_type <- "point" - } else if (sf_type == "line") { - self$computed_legend_key_type <- "line" - } - } - } - } else { - self$computed_legend_key_type <- self$legend_key_type - } data }, compute_geom_1 = function(self, data) { data <- ggproto_parent(Layer, self)$compute_geom_1(data) + # Determine the legend type + legend_type <- self$legend_key_type + if (is.null(legend_type)) { + legend_type <- switch( + detect_sf_type(data$geometry), + point = "point", line = "line", "other" + ) + } + # Add legend type after computed_geom_params has been calculated - self$computed_geom_params$legend <- self$computed_legend_key_type + self$computed_geom_params$legend <- legend_type data } ) @@ -113,6 +97,9 @@ scale_type.sfc <- function(x) "identity" # helper function to determine the geometry type of sf object detect_sf_type <- function(sf) { + if (is.null(sf)) { + return("other") + } geometry_type <- unique0(as.character(sf::st_geometry_type(sf))) if (length(geometry_type) != 1) geometry_type <- "GEOMETRY" sf_types[geometry_type] diff --git a/tests/testthat/test-geom-sf.R b/tests/testthat/test-geom-sf.R index cfc662f442..666c9799ea 100644 --- a/tests/testthat/test-geom-sf.R +++ b/tests/testthat/test-geom-sf.R @@ -37,7 +37,7 @@ test_that("geom_sf() determines the legend type automatically", { expect_identical(fun_geom_sf(mls, TRUE)$plot$layers[[1]]$computed_geom_params$legend, "line") expect_identical(fun_geom_sf(mpol, TRUE)$plot$layers[[1]]$show.legend, TRUE) - expect_identical(fun_geom_sf(mpol, TRUE)$plot$layers[[1]]$computed_geom_params$legend, "polygon") + expect_identical(fun_geom_sf(mpol, TRUE)$plot$layers[[1]]$computed_geom_params$legend, "other") # test that automatic choice can be overridden manually expect_identical(fun_geom_sf(mp, "point")$plot$layers[[1]]$show.legend, TRUE) @@ -74,13 +74,6 @@ test_that("geom_sf() determines the legend type from mapped geometry column", { ggplot(d_sf) + geom_sf(aes(geometry = g_line, colour = "a")) ) expect_identical(p$plot$layers[[1]]$computed_geom_params$legend, "line") - - # If `geometry` is not a symbol, `LayerSf$setup_layer()` gives up guessing - # the legend type, and falls back to "polygon" - p <- ggplot_build( - ggplot(d_sf) + geom_sf(aes(geometry = identity(g_point), colour = "a")) - ) - expect_identical(p$plot$layers[[1]]$computed_geom_params$legend, "polygon") }) test_that("geom_sf() removes rows containing missing aes", { From 099de257e5514479397c18d805c179de6f4ec14c Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 23 May 2024 10:29:02 +0200 Subject: [PATCH 7/8] geom_sf can compute defaults for legend --- R/geom-sf.R | 9 +++++++-- R/layer-sf.R | 5 +++++ 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/R/geom-sf.R b/R/geom-sf.R index c0541cf369..fed763df79 100644 --- a/R/geom-sf.R +++ b/R/geom-sf.R @@ -131,7 +131,8 @@ GeomSf <- ggproto("GeomSf", Geom, stroke = 0.5 ), - use_defaults = function(self, data, params = list(), modifiers = aes(), default_aes = NULL) { + 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)) { @@ -139,7 +140,11 @@ GeomSf <- ggproto("GeomSf", Geom, } # Devise splitting index for geometry types - type <- sf_types[sf::st_geometry_type(data$geometry)] + type <- if (is.character(data$geometry)) { + data$geometry + } else { + sf_types[sf::st_geometry_type(data$geometry)] + } type <- factor(type, c("point", "line", "other", "collection")) index <- split(seq_len(nrow(data)), type) diff --git a/R/layer-sf.R b/R/layer-sf.R index ad085a8e8f..437ecef3df 100644 --- a/R/layer-sf.R +++ b/R/layer-sf.R @@ -69,6 +69,11 @@ LayerSf <- ggproto("LayerSf", Layer, # Add legend type after computed_geom_params has been calculated self$computed_geom_params$legend <- legend_type data + }, + + compute_geom_2 = function(self, data, params = self$aes_params, ...) { + data$geometry <- data$geometry %||% self$computed_geom_params$legend + ggproto_parent(Layer, self)$compute_geom_2(data, params, ...) } ) From 3e7ea3451a0229a4b69af3781b06fa7cb8323477 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 23 May 2024 10:29:42 +0200 Subject: [PATCH 8/8] remove vestigial `default_aesthetics()` --- R/geom-sf.R | 27 ++++++++------------------- 1 file changed, 8 insertions(+), 19 deletions(-) diff --git a/R/geom-sf.R b/R/geom-sf.R index fed763df79..ba559c1243 100644 --- a/R/geom-sf.R +++ b/R/geom-sf.R @@ -134,17 +134,18 @@ GeomSf <- ggproto("GeomSf", Geom, 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 + # geometry column is a character if we're populating legend keys type <- if (is.character(data$geometry)) { data$geometry } else { sf_types[sf::st_geometry_type(data$geometry)] } + + # Devise splitting index for geometry types type <- factor(type, c("point", "line", "other", "collection")) index <- split(seq_len(nrow(data)), type) @@ -207,27 +208,15 @@ GeomSf <- ggproto("GeomSf", Geom, }, draw_key = function(data, params, size) { - data <- modify_list(default_aesthetics(params$legend), data) - if (params$legend == "point") { - draw_key_point(data, params, size) - } else if (params$legend == "line") { - draw_key_path(data, params, size) - } else { + switch( + params$legend %||% "other", + point = draw_key_point(data, params, size), + line = draw_key_path(data, params, size), draw_key_polygon(data, params, size) - } + ) } ) -default_aesthetics <- function(type) { - if (type == "point") { - GeomPoint$default_aes - } else if (type == "line") { - GeomLine$default_aes - } else { - modify_list(GeomPolygon$default_aes, list(fill = "grey90", colour = "grey35")) - } -} - sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10, arrow = NULL, arrow.fill = NULL, na.rm = TRUE) { type <- sf_types[sf::st_geometry_type(x$geometry)]