diff --git a/NEWS.md b/NEWS.md index 9043752ad0..a7bd1b024e 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. + * `coord_radial()` is a successor to `coord_polar()` with more customisation options. `coord_radial()` can: diff --git a/R/guide-bins.R b/R/guide-bins.R index 1f2228c8c3..77ea847b53 100644 --- a/R/guide-bins.R +++ b/R/guide-bins.R @@ -368,14 +368,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 3a0d2bb8a7..cb5d671393 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -513,7 +513,8 @@ GuideLegend <- ggproto( keys <- lapply(decor, function(g) { data <- vec_slice(g$data, i) if (data$.draw %||% TRUE) { - g$draw_key(data, g$params, key_size) + key <- g$draw_key(data, g$params, key_size) + set_key_size(key, data$linewidth, data$size, key_size / 10) } else { zeroGrob() } @@ -550,7 +551,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 ) @@ -776,41 +777,55 @@ 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) + } + 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 +} + # 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), 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 923191b475..6e6b84f093 100644 --- a/tests/testthat/test-draw-key.R +++ b/tests/testthat/test-draw-key.R @@ -20,6 +20,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", {