diff --git a/NEWS.md b/NEWS.md
index 3ac733842e..5c44f2910c 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -29,6 +29,11 @@
* More informative error for mismatched
`direction`/`theme(legend.direction = ...)` arguments (#4364, #4930).
* `guide_coloursteps()` and `guide_bins()` sort breaks (#5152).
+ * `guide_legend()` now omits inappropriate key glyphs: if there isn't any
+ layer data matching a key value, the key isn't drawn. To show keys in the
+ legend regardless of whether the value occurs in the data
+ (the old behaviour), you can use `show.legend = c({aesthetic} = TRUE)`
+ (@teunbrand, #3648).
* `geom_label()` now uses the `angle` aesthetic (@teunbrand, #2785)
* 'lines' units in `geom_label()`, often used in the `label.padding` argument,
diff --git a/R/guide-.R b/R/guide-.R
index a1c194bf99..51395bf010 100644
--- a/R/guide-.R
+++ b/R/guide-.R
@@ -175,7 +175,7 @@ Guide <- ggproto(
# Function for extracting information from the layers.
# Mostly applies to `guide_legend()` and `guide_binned()`
- get_layer_key = function(params, layers) {
+ get_layer_key = function(params, layers, key_data) {
return(params)
},
diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R
index 65291f37cc..63e766ec51 100644
--- a/R/guide-colorbar.R
+++ b/R/guide-colorbar.R
@@ -373,7 +373,7 @@ GuideColourbar <- ggproto(
return(list(guide = self, params = params))
},
- get_layer_key = function(params, layers) {
+ get_layer_key = function(params, layers, key_data) {
guide_layers <- lapply(layers, function(layer) {
diff --git a/R/guide-legend.R b/R/guide-legend.R
index 0e6193aa24..429358c5c4 100644
--- a/R/guide-legend.R
+++ b/R/guide-legend.R
@@ -294,9 +294,9 @@ GuideLegend <- ggproto(
},
# Arrange common data for vertical and horizontal legends
- get_layer_key = function(params, layers) {
+ get_layer_key = function(params, layers, key_data) {
- decor <- lapply(layers, function(layer) {
+ decor <- Map(function(layer, index) {
matched_aes <- matched_aes(layer, params)
@@ -322,9 +322,11 @@ GuideLegend <- ggproto(
"Failed to apply {.fn after_scale} modifications to legend",
parent = cnd
)
- layer$geom$use_defaults(params$key[matched], layer_params, list())
+ layer$geom$use_defaults(params$key[matched_aes], layer_params, list())
}
)
+ data$.draw <- keep_key_data(params$key, key_data, matched_aes,
+ layer$show.legend, index)
} else {
reps <- rep(1, nrow(params$key))
data <- layer$geom$use_defaults(NULL, layer$aes_params)[reps, ]
@@ -341,7 +343,7 @@ GuideLegend <- ggproto(
data = data,
params = c(layer$computed_geom_params, layer$computed_stat_params)
)
- })
+ }, layer = layers, index = seq_along(layers))
# Remove NULL geoms
params$decor <- compact(decor)
@@ -472,7 +474,12 @@ GuideLegend <- ggproto(
draw <- function(i) {
bg <- elements$key
keys <- lapply(decor, function(g) {
- g$draw_key(vec_slice(g$data, i), g$params, key_size)
+ data <- vec_slice(g$data, i)
+ if (data$.draw %||% TRUE) {
+ g$draw_key(data, g$params, key_size)
+ } else {
+ zeroGrob()
+ }
})
c(list(bg), keys)
}
@@ -749,3 +756,47 @@ measure_legend_keys <- function(decor, n, dim, byrow = FALSE,
heights = pmax(default_height, apply(size, 1, max))
)
}
+
+# The `keep_key_data` function is for deciding whether keys should be drawn or
+# not based on key data collected by the scales.
+keep_key_data <- function(key, data, aes, show, index) {
+ # Figure out whether the layer should have trimmed keys based on the
+ # `show`, i.e. `layer$show.legend` parameter.
+ if (is_named(show)) {
+ trim <- is.na(show[aes])
+ aes <- aes[trim]
+ if (length(aes) == 0) {
+ # No matching aesthetic, probably should keep everything
+ return(TRUE)
+ }
+ trim <- any(trim)
+ } else {
+ trim <- is.na(show[1])
+ }
+ if (!trim) {
+ # No matching aesthetic, probably should keep everything
+ return(TRUE)
+ }
+ # Figure out if we have matching key data
+ match <- lapply(data, function(x) {which(aes %in% x$aesthetics)})
+ lengs <- lengths(match)
+ if (sum(lengs) == 0) {
+ # We don't have matching key data, probably should keep everything
+ return(TRUE)
+ }
+
+ # Subset for cases where we *do* have key data
+ data <- data[lengs > 0]
+ match <- unlist(match[lengs > 0])
+ data <- lapply(data, `[[`, "data")[match]
+
+ # Lookup if we have entries for the keys
+ for (i in seq_along(aes)) {
+ keep <- data[[i]]$pal %in% key[[aes[i]]]
+ data[[i]] <- vec_slice(data[[i]]$member, keep)[, index]
+ }
+
+ # If we have multiple matching aesthetics, either one of them is good enough
+ # to keep the data
+ Reduce(`|`, data)
+}
diff --git a/R/guides-.R b/R/guides-.R
index 66883b0e58..5c8fce770b 100644
--- a/R/guides-.R
+++ b/R/guides-.R
@@ -244,7 +244,7 @@ Guides <- ggproto(
# arrange all guide grobs
build = function(self, scales, layers, default_mapping,
- position, theme, labels) {
+ position, theme, labels, key_data) {
position <- legend_position(position)
no_guides <- zeroGrob()
@@ -279,7 +279,7 @@ Guides <- ggproto(
# Merge and process layers
guides$merge()
- guides$process_layers(layers)
+ guides$process_layers(layers, key_data)
if (length(guides$guides) == 0) {
return(no_guides)
}
@@ -438,9 +438,9 @@ Guides <- ggproto(
},
# Loop over guides to let them extract information from layers
- process_layers = function(self, layers) {
+ process_layers = function(self, layers, key_data) {
self$params <- Map(
- function(guide, param) guide$get_layer_key(param, layers),
+ function(guide, param) guide$get_layer_key(param, layers, key_data),
guide = self$guides,
param = self$params
)
diff --git a/R/plot-build.R b/R/plot-build.R
index 1bf0019324..a0442559bf 100644
--- a/R/plot-build.R
+++ b/R/plot-build.R
@@ -89,6 +89,7 @@ ggplot_build.ggplot <- function(plot) {
if (npscales$n() > 0) {
lapply(data, npscales$train_df)
data <- lapply(data, npscales$map_df)
+ plot$key_data <- npscales$key_data(data)
}
# Fill in defaults etc.
@@ -178,7 +179,8 @@ ggplot_gtable.ggplot_built <- function(data) {
}
legend_box <- plot$guides$build(
- plot$scales, plot$layers, plot$mapping, position, theme, plot$labels
+ plot$scales, plot$layers, plot$mapping, position, theme, plot$labels,
+ plot$key_data
)
if (is.zero(legend_box)) {
diff --git a/R/scales-.R b/R/scales-.R
index 73c490c8a2..11c47ec801 100644
--- a/R/scales-.R
+++ b/R/scales-.R
@@ -81,6 +81,37 @@ ScalesList <- ggproto("ScalesList", NULL,
data_frame0(!!!mapped, df[setdiff(names(df), names(mapped))])
},
+ key_data = function(self, data) {
+
+ scales <- self$scales
+
+ lapply(scales, function(s) {
+ if (!s$is_discrete()) {
+ return(NULL)
+ }
+ n <- s$n.breaks.cache %||% sum(!is.na(s$limits %|W|% s$get_limits()))
+ if (n < 1) {
+ return(NULL)
+ }
+ pal <- s$palette.cache %||% s$palette(n)
+ pal <- c(pal, s$na.value)
+ aes <- s$aesthetics
+ out <- vapply(data, function(d) {
+ if (!any(aes %in% names(d))) {
+ return(rep.int(FALSE, length(pal)))
+ }
+ present <- vapply(aes, function(a) {
+ vec_in(pal, d[[a]])
+ }, logical(length(pal)))
+ if (length(dim(present)) > 1) {
+ present <- rowSums(present) > 0
+ }
+ present
+ }, logical(length(pal)))
+ list(aesthetics = aes, data = data_frame0(pal = pal, member = out))
+ })
+ },
+
transform_df = function(self, df) {
if (empty(df)) {
return(df)
diff --git a/tests/testthat/_snaps/draw-key/legend-key-selection.svg b/tests/testthat/_snaps/draw-key/legend-key-selection.svg
new file mode 100644
index 0000000000..77db5e48c4
--- /dev/null
+++ b/tests/testthat/_snaps/draw-key/legend-key-selection.svg
@@ -0,0 +1,89 @@
+
+
diff --git a/tests/testthat/_snaps/draw-key/partial-legend-key-selection.svg b/tests/testthat/_snaps/draw-key/partial-legend-key-selection.svg
new file mode 100644
index 0000000000..ac99db7e2f
--- /dev/null
+++ b/tests/testthat/_snaps/draw-key/partial-legend-key-selection.svg
@@ -0,0 +1,90 @@
+
+
diff --git a/tests/testthat/test-draw-key.R b/tests/testthat/test-draw-key.R
index aeba592a6c..8147e58c21 100644
--- a/tests/testthat/test-draw-key.R
+++ b/tests/testthat/test-draw-key.R
@@ -18,6 +18,88 @@ test_that("alternative key glyphs work", {
)
})
+test_that("keep_key_data give expected output", {
+
+ key <- data_frame0(
+ colour = c("red", "green", "blue"),
+ label = c("A", "B", "C")
+ )
+
+ data <- list(
+ list(
+ aesthetics = "colour",
+ data = data_frame0(
+ pal = c("red", "green", "blue", "orange"),
+ member = matrix(c(
+ TRUE, TRUE, FALSE, FALSE,
+ FALSE, TRUE, TRUE, TRUE
+ ), 4, 2)
+ )
+ )
+ )
+
+ expect_equal( # show = TRUE, so keep everything
+ keep_key_data(key, data, "colour", show = TRUE, index = 1),
+ TRUE
+ )
+ expect_equal( # check for first index
+ keep_key_data(key, data, "colour", show = NA, index = 1),
+ c(TRUE, TRUE, FALSE)
+ )
+ expect_equal( # check for second index
+ keep_key_data(key, data, "colour", show = NA, index = 2),
+ c(FALSE, TRUE, TRUE)
+ )
+ expect_equal( # colour = TRUE, not NA, so keep everything
+ keep_key_data(key, data, "colour", show = c(label = NA, colour = TRUE), index = 1),
+ TRUE
+ )
+ expect_equal( # colour = NA, so check for colour matches
+ keep_key_data(key, data, "colour", show = c(label = TRUE, colour = NA), index = 1),
+ c(TRUE, TRUE, FALSE)
+ )
+ expect_equal( # No relevant key data, keep everything
+ keep_key_data(key, data, "label", show = c(label = NA), index = 1),
+ TRUE
+ )
+ data[[2]] <- list(
+ aesthetics = "label",
+ data = data_frame0(
+ pal = c("A", "B", "C"),
+ member = matrix(c(
+ TRUE, FALSE, TRUE,
+ FALSE, FALSE, TRUE
+ ), 3, 2)
+ )
+ )
+ expect_equal( # All keys: colour matches first two, label the third key
+ keep_key_data(key, data, c("colour", "label"), show = NA, index = 1),
+ c(TRUE, TRUE, TRUE)
+ )
+ expect_equal( # First key matches neither, so give 1st FALSE
+ keep_key_data(key, data, c("colour", "label"), show = NA, index = 2),
+ c(FALSE, TRUE, TRUE)
+ )
+})
+
+test_that("key selection works appropriately", {
+
+ data46 <- subset(mtcars, cyl %in% c(4, 6))
+ data68 <- subset(mtcars, cyl %in% c(6, 8))
+
+ p <- ggplot(mapping = aes(disp, mpg, colour = factor(cyl))) +
+ geom_point(data = data46) +
+ geom_path(data = data68)
+
+ expect_doppelganger("legend key selection", p)
+
+ p <- ggplot(mapping = aes(disp, mpg, colour = factor(cyl))) +
+ geom_point(data = data46, show.legend = TRUE) +
+ geom_path(data = data68)
+
+ expect_doppelganger("partial legend key selection", p)
+})
+
# Orientation-aware key glyphs --------------------------------------------
test_that("horizontal key glyphs work", {