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/geom-sf.R b/R/geom-sf.R
index c0541cf369..ba559c1243 100644
--- a/R/geom-sf.R
+++ b/R/geom-sf.R
@@ -131,15 +131,21 @@ 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)) {
return(data)
}
+ # 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 <- sf_types[sf::st_geometry_type(data$geometry)]
type <- factor(type, c("point", "line", "other", "collection"))
index <- split(seq_len(nrow(data)), type)
@@ -202,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)]
diff --git a/R/guide-legend.R b/R/guide-legend.R
index 2ef01fbae9..95dba1cfa0 100644
--- a/R/guide-legend.R
+++ b/R/guide-legend.R
@@ -225,31 +225,36 @@ 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]
+ key$.id <- seq_len(nrow(key))
- 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)
)
})
diff --git a/R/layer-sf.R b/R/layer-sf.R
index 4a1b8e6512..437ecef3df 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,35 +52,28 @@ 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
+ },
+
+ 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, ...)
}
)
@@ -113,6 +102,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/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) {
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 @@
+
+
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 @@
+
+
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 @@
+
+
diff --git a/tests/testthat/test-geom-sf.R b/tests/testthat/test-geom-sf.R
index d79146ff73..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", {
@@ -196,6 +189,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")
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", {