Smarter keys

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, 

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)
   },
 

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) {
 

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)
+}

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
     )

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)) {

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)