From 274ec06c86c81887823abdd3f0a0aa28e1c3fd10 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 10 Oct 2023 15:04:44 +0200 Subject: [PATCH 1/5] Mechanism for setting key sizes --- R/guide-legend.R | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/R/guide-legend.R b/R/guide-legend.R index 087e3e6fef..6334d78acd 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -463,7 +463,9 @@ 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) + key <- g$draw_key(data, g$params, key_size) + set_key_size(key, data$linewidth, data$size, key_size / 10) }) c(list(bg), keys) } @@ -756,3 +758,21 @@ measure_legend_keys <- function(decor, n, dim, byrow = FALSE, heights = pmax(default_height, apply(size, 1, max)) ) } + +set_key_size <- function(key, linewidth = NULL, size = NULL, default = NULL) { + if (!is.null(attr(key, "width")) && !is.null(attr(key, 'height'))) { + return(key) + } + if (!is.null(size) || !is.null(linewidth)) { + size <- size %||% 0 + linewidth <- linewidth %||% 0 + size <- if (is.na(size)[1]) 0 else size[1] + linewidth <- if (is.na(linewidth)[1]) 0 else linewidth[1] + size <- (size + linewidth) / 10 # From mm to cm + } else { + size <- NULL + } + attr(key, "width") <- attr(key, "width", TRUE) %||% size %||% default[1] + attr(key, "height") <- attr(key, "height", TRUE) %||% size %||% default[2] + key +} From 01165d45776f443dbbd11c310af4d8853ff8f59e Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 10 Oct 2023 15:05:03 +0200 Subject: [PATCH 2/5] Mechanism for getting key sizes --- R/guide-legend.R | 36 ++++++++++++++++-------------------- 1 file changed, 16 insertions(+), 20 deletions(-) diff --git a/R/guide-legend.R b/R/guide-legend.R index 6334d78acd..0889fbab6c 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -724,41 +724,37 @@ GuideLegend <- ggproto( label_hjust_defaults <- c(top = 0.5, bottom = 0.5, left = 1, right = 0) label_vjust_defaults <- c(top = 0, bottom = 1, left = 0.5, right = 0.5) -measure_legend_keys <- function(decor, n, dim, byrow = FALSE, +measure_legend_keys <- function(keys, n, dim, byrow = FALSE, default_width = 1, default_height = 1) { - if (is.null(decor)) { + if (is.null(keys)) { ans <- list(widths = NULL, heights = NULL) return(ans) } # Vector padding in case rows * cols > keys - zeroes <- rep(0, prod(dim) - n) + padding_zeroes <- rep(0, prod(dim) - n) # For every layer, extract the size in cm - size <- lapply(decor, function(g) { - lwd <- g$data$linewidth %||% 0 - lwd[is.na(lwd)] <- 0 - size <- g$data$size %||% 0 - size[is.na(size)] <- 0 - vec_recycle((size + lwd) / 10, size = nrow(g$data)) - }) - size <- inject(cbind(!!!size)) - - # Binned legends may have `n + 1` breaks, but we need to display `n` keys. - size <- vec_slice(size, seq_len(n)) - - # For every key, find maximum across all layers - size <- apply(size, 1, max) + widths <- c(get_key_size(keys, "width", n), padding_zeroes) + heights <- c(get_key_size(keys, "height", n), padding_zeroes) # Apply legend layout - size <- matrix(c(size, zeroes), nrow = dim[1], ncol = dim[2], byrow = byrow) + widths <- matrix(widths, nrow = dim[1], ncol = dim[2], byrow = byrow) + heights <- matrix(heights, nrow = dim[1], ncol = dim[2], byrow = byrow) list( - widths = pmax(default_width, apply(size, 2, max)), - heights = pmax(default_height, apply(size, 1, max)) + widths = pmax(default_width, apply(widths, 2, max)), + heights = pmax(default_height, apply(heights, 1, max)) ) } +get_key_size <- function(keys, which = "width", n) { + size <- lapply(keys, attr, which = which) + size[lengths(size) != 1] <- 0 + size <- matrix(unlist(size), ncol = n) + apply(size, 2, max) +} + set_key_size <- function(key, linewidth = NULL, size = NULL, default = NULL) { if (!is.null(attr(key, "width")) && !is.null(attr(key, 'height'))) { return(key) From 0b8592f673e17b20f7ad2bd2985bcb3f5f9672a5 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 10 Oct 2023 15:05:39 +0200 Subject: [PATCH 3/5] Feed key grobs to `measure_label_sizes()` --- R/guide-bins.R | 5 +++-- R/guide-legend.R | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/R/guide-bins.R b/R/guide-bins.R index 63c75bd0bd..137af1fb64 100644 --- a/R/guide-bins.R +++ b/R/guide-bins.R @@ -372,14 +372,15 @@ GuideBins <- ggproto( dim <- if (params$direction == "vertical") c(nkeys, 1) else c(1, nkeys) + decor <- GuideLegend$build_decor(decor, grobs, elements, params) + sizes <- measure_legend_keys( - params$decor, nkeys, dim, byrow = FALSE, + decor, nkeys, dim, byrow = FALSE, default_width = elements$key.width, default_height = elements$key.height ) sizes <- lapply(sizes, function(x) rep_len(max(x), length(x))) - decor <- GuideLegend$build_decor(decor, grobs, elements, params) n_layers <- length(decor) / nkeys key_id <- rep(seq_len(nkeys), each = n_layers) key_nm <- paste("key", key_id, c("bg", seq_len(n_layers - 1))) diff --git a/R/guide-legend.R b/R/guide-legend.R index 0889fbab6c..f0c28e540f 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -499,7 +499,7 @@ GuideLegend <- ggproto( # A guide may have already specified the size of the decoration, only # measure when it hasn't already. sizes <- params$sizes %||% measure_legend_keys( - params$decor, n = n_breaks, dim = dim, byrow = byrow, + grobs$decor, n = n_breaks, dim = dim, byrow = byrow, default_width = elements$key.width, default_height = elements$key.height ) From 62e61b49bc29b5ab92b2414f66259673f3b74d2c Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 10 Oct 2023 15:06:26 +0200 Subject: [PATCH 4/5] Add test --- .../draw-key/circle-glyphs-of-2cm-size.svg | 100 ++++++++++++++++++ tests/testthat/test-draw-key.R | 16 +++ 2 files changed, 116 insertions(+) create mode 100644 tests/testthat/_snaps/draw-key/circle-glyphs-of-2cm-size.svg diff --git a/tests/testthat/_snaps/draw-key/circle-glyphs-of-2cm-size.svg b/tests/testthat/_snaps/draw-key/circle-glyphs-of-2cm-size.svg new file mode 100644 index 0000000000..a5f3eb8c3d --- /dev/null +++ b/tests/testthat/_snaps/draw-key/circle-glyphs-of-2cm-size.svg @@ -0,0 +1,100 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2 +3 +4 +5 + + + + + + + + + + +10 +15 +20 +25 +30 +35 +mpg +wt + +factor(cyl) + + + + + + +4 +6 +8 +circle glyphs of 2cm size + + diff --git a/tests/testthat/test-draw-key.R b/tests/testthat/test-draw-key.R index aeba592a6c..2e101a37b4 100644 --- a/tests/testthat/test-draw-key.R +++ b/tests/testthat/test-draw-key.R @@ -18,6 +18,22 @@ test_that("alternative key glyphs work", { ) }) +test_that("keys can communicate their size", { + + draw_key_dummy <- function(data, params, size) { + grob <- circleGrob(r = unit(1, "cm")) + attr(grob, "width") <- 2 + attr(grob, "height") <- 2 + grob + } + + expect_doppelganger( + "circle glyphs of 2cm size", + ggplot(mtcars, aes(mpg, wt, colour = factor(cyl))) + + geom_point(key_glyph = draw_key_dummy) + ) +}) + # Orientation-aware key glyphs -------------------------------------------- test_that("horizontal key glyphs work", { From a0d8dd4667e4662c81c85d882e92bf8c24c83011 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 10 Oct 2023 15:08:16 +0200 Subject: [PATCH 5/5] Add news bullet --- NEWS.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/NEWS.md b/NEWS.md index bc1f4059e8..4b9aed74d2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # ggplot2 (development version) +* Glyphs drawing functions of the `draw_key_*()` family can now set `"width"` + and `"height"` attributes (in centimetres) to the produced keys to control + their displayed size in the legend. + * Legend titles no longer take up space if they've been removed by setting `legend.title = element_blank()` (@teunbrand, #3587).