From 8eb0d80bda196ff4695268619cfb5238f8bdfc51 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sun, 7 May 2023 23:28:15 +0200 Subject: [PATCH 01/10] Add `key_data` to `$get_layer_key()` --- R/guide-.R | 2 +- R/guide-colorbar.R | 2 +- R/guide-legend.R | 2 +- R/guides-.R | 8 ++++---- 4 files changed, 7 insertions(+), 7 deletions(-) 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..cc6ce57b34 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -294,7 +294,7 @@ 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) { 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 ) From 7927b6d27880ac6315c3e625872a4c0817ac464f Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sun, 7 May 2023 23:28:34 +0200 Subject: [PATCH 02/10] Add key data extractor --- R/scales-.R | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) 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) From eeadca80ab54725fcdd545cc8e6787d6a6096882 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sun, 7 May 2023 23:28:51 +0200 Subject: [PATCH 03/10] Pass along key data --- R/plot-build.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) 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)) { From e01b6935082258f80da24f445d9831e07d1e3173 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sun, 7 May 2023 23:29:16 +0200 Subject: [PATCH 04/10] fix typo --- R/guide-legend.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/guide-legend.R b/R/guide-legend.R index cc6ce57b34..214b681564 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -322,7 +322,7 @@ 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()) } ) } else { From bf06916ee89bba10e91bc0e318bcb831378a2aa7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sun, 7 May 2023 23:29:44 +0200 Subject: [PATCH 05/10] Conditionally draw key --- R/guide-legend.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/R/guide-legend.R b/R/guide-legend.R index 214b681564..1b222cef78 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -472,7 +472,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) } From 3cf3f3eaea549c3623f2db2eac6bd0a777e9fa30 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sun, 7 May 2023 23:30:14 +0200 Subject: [PATCH 06/10] Add trimmer --- R/guide-legend.R | 35 +++++++++++++++++++++++++++++++++-- 1 file changed, 33 insertions(+), 2 deletions(-) diff --git a/R/guide-legend.R b/R/guide-legend.R index 1b222cef78..9b38b68aa0 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -296,7 +296,7 @@ GuideLegend <- ggproto( # Arrange common data for vertical and horizontal legends get_layer_key = function(params, layers, key_data) { - decor <- lapply(layers, function(layer) { + decor <- Map(function(layer, index) { matched_aes <- matched_aes(layer, params) @@ -325,6 +325,8 @@ GuideLegend <- ggproto( layer$geom$use_defaults(params$key[matched_aes], layer_params, list()) } ) + data$.draw <- trim_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) @@ -754,3 +756,32 @@ measure_legend_keys <- function(decor, n, dim, byrow = FALSE, heights = pmax(default_height, apply(size, 1, max)) ) } + +trim_key_data <- function(key, data, aes, show, index) { + if (is_named(show)) { + trim <- is.na(show[aes]) + aes <- aes[trim] + if (length(aes) == 0) { + return(TRUE) + } + trim <- any(trim) + } else { + trim <- is.na(show[1]) + } + if (!trim) { + return(TRUE) + } + match <- lapply(data, function(x) {which(aes %in% x$aesthetics)}) + lengs <- lengths(match) + if (sum(lengs) == 0) { + return(TRUE) + } + data <- data[lengs > 0] + match <- unlist(match[lengs > 0]) + data <- lapply(data, `[[`, "data")[match] + for (i in seq_along(aes)) { + keep <- data[[i]]$pal %in% key[[aes[i]]] + data[[i]] <- vec_slice(data[[i]]$member, keep)[, index] + } + Reduce(`|`, data) +} From d2d8ff13b3f8bf8a0dd4db058f7ff91894690e3d Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 8 May 2023 19:01:03 +0200 Subject: [PATCH 07/10] Sprinkle some comments around --- R/guide-legend.R | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/R/guide-legend.R b/R/guide-legend.R index 9b38b68aa0..429358c5c4 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -325,7 +325,7 @@ GuideLegend <- ggproto( layer$geom$use_defaults(params$key[matched_aes], layer_params, list()) } ) - data$.draw <- trim_key_data(params$key, key_data, matched_aes, + data$.draw <- keep_key_data(params$key, key_data, matched_aes, layer$show.legend, index) } else { reps <- rep(1, nrow(params$key)) @@ -757,11 +757,16 @@ measure_legend_keys <- function(decor, n, dim, byrow = FALSE, ) } -trim_key_data <- function(key, data, aes, show, index) { +# 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) @@ -769,19 +774,29 @@ trim_key_data <- function(key, data, aes, show, index) { 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) } From d0f4eaa3bab881721d8afd4bbe25e7dd0a95abdf Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 9 May 2023 20:14:12 +0200 Subject: [PATCH 08/10] Add tests --- tests/testthat/test-draw-key.R | 82 ++++++++++++++++++++++++++++++++++ 1 file changed, 82 insertions(+) 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", { From 95225403dd16422849afeab869b1672cd2520217 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 9 May 2023 20:20:24 +0200 Subject: [PATCH 09/10] Add NEWS bullet --- NEWS.md | 5 +++++ 1 file changed, 5 insertions(+) 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, From a1f396d0b56a95857eb871f62a1a7804536eb210 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 9 May 2023 20:41:35 +0200 Subject: [PATCH 10/10] Include snapshots --- .../_snaps/draw-key/legend-key-selection.svg | 89 ++++++++++++++++++ .../draw-key/partial-legend-key-selection.svg | 90 +++++++++++++++++++ 2 files changed, 179 insertions(+) create mode 100644 tests/testthat/_snaps/draw-key/legend-key-selection.svg create mode 100644 tests/testthat/_snaps/draw-key/partial-legend-key-selection.svg 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 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + + + + +100 +200 +300 +400 +disp +mpg + +factor(cyl) + + + + + + + +4 +6 +8 +legend key selection + + 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 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + + + + +100 +200 +300 +400 +disp +mpg + +factor(cyl) + + + + + + + + +4 +6 +8 +partial legend key selection + +