Smarter keys (attempt 2) (#5502)

* fix typo

* Switch for drawing keys

* `lapply` -> `Map()`

* Helper function

* write test

* accept snapshots

* Add news bullet

NEWS.md

@@ -1,5 +1,9 @@
 # ggplot2 (development version)
 
+* By default, `guide_legend()` now only draws a key glyph for a layer when
+  the value is is the layer's data. To revert to the old behaviour, you
+  can still set `show.legend = c({aesthetic} = TRUE)` (@teunbrand, #3648).
+
 * The spacing between legend keys and their labels, in addition to legends
   and their titles, is now controlled by the text's `margin` setting. Not
   specifying margins will automatically add appropriate text margins. To

R/guide-legend.R

@@ -322,7 +322,7 @@ GuideLegend <- ggproto(
 
   get_layer_key = function(params, layers, data) {
 
-    decor <- lapply(layers, function(layer) {
+    decor <- Map(layer = layers, df = data, f = function(layer, df) {
 
       matched_aes <- matched_aes(layer, params)
 
@@ -343,9 +343,10 @@ 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, df, matched_aes, layer$show.legend)
       } else {
         reps <- rep(1, nrow(params$key))
         data <- layer$geom$use_defaults(NULL, layer$aes_params)[reps, ]
@@ -510,7 +511,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)
     }
@@ -804,3 +810,38 @@ measure_legend_keys <- function(decor, n, dim, byrow = FALSE,
     heights = pmax(default_height, apply(size, 1, max))
   )
 }
+
+# For legend keys, check if the guide key's `.value` also occurs in the layer
+# data when `show.legend = NA` and data is discrete. Note that `show.legend`
+# besides TRUE (always show), FALSE (never show) and NA (show in relevant legend),
+# can also take *named* logical vector to set this behaviour per aesthetic.
+keep_key_data <- function(key, data, aes, show) {
+  # First, can we exclude based on anything else than actually checking the
+  # data that we should include or drop the key?
+  if (!is.discrete(key$.value)) {
+    return(TRUE)
+  }
+  if (is_named(show)) {
+    aes  <- intersect(aes, names(show))
+    show <- show[aes]
+  } else {
+    show <- show[rep(1L, length(aes))]
+  }
+  if (isTRUE(any(show)) || length(show) == 0) {
+    return(TRUE)
+  }
+  if (isTRUE(all(!show))) {
+    return(FALSE)
+  }
+  # Second, we go find if the value is actually present in the data.
+  aes <- aes[is.na(show)]
+  match <- which(names(data) %in% aes)
+  if (length(match) == 0) {
+    return(TRUE)
+  }
+  keep <- rep(FALSE, nrow(key))
+  for (column in match) {
+    keep <- keep | vec_in(key$.value, data[[column]])
+  }
+  keep
+}

tests/testthat/test-draw-key.R

@@ -55,3 +55,42 @@ test_that("horizontal key glyphs work", {
       guides(color = guide_legend(order = 1))
   )
 })
+
+test_that("keep_draw_key", {
+
+  key  <- data_frame0(.value = c("A", "C"))
+  data <- data_frame0(foo = c("A", "B"), bar = c("B", "C"))
+
+  expect_true( keep_key_data(key, data, "foo", show = TRUE))
+  expect_false(keep_key_data(key, data, "foo", show = FALSE))
+  expect_equal(keep_key_data(key, data, "foo", show = NA), c(TRUE, FALSE))
+  expect_equal(keep_key_data(key, data, "bar", show = NA), c(FALSE, TRUE))
+  expect_equal(keep_key_data(key, data, c("foo", "bar"), show = NA), c(TRUE, TRUE))
+
+  # Named show
+  expect_true(
+    keep_key_data(key, data, c("foo", "bar"), show = c(foo = TRUE, bar = FALSE))
+  )
+  expect_equal(
+    keep_key_data(key, data, c("foo", "bar"), show = c(foo = NA, bar = FALSE)),
+    c(TRUE, FALSE)
+  )
+  expect_equal(
+    keep_key_data(key, data, c("foo", "bar"), show = c(foo = FALSE, bar = NA)),
+    c(FALSE, TRUE)
+  )
+
+  p <- ggplot(data.frame(x = 1:2), aes(x, x)) +
+    geom_point(
+      aes(colour = "point", alpha = "point"),
+      show.legend = c("colour" = NA, alpha = FALSE)
+    ) +
+    geom_line(
+      aes(colour = "line", alpha = "line"),
+      show.legend = c("colour" = NA, alpha = TRUE)
+    ) +
+    suppressWarnings(scale_alpha_discrete())
+
+  expect_doppelganger("appropriate colour key with alpha key as lines", p)
+
+})