Custom key glyph sizes

NEWS.md

@@ -1,5 +1,8 @@
 # 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.
 * `ggsave()` no longer sometimes creates new directories, which is now 
   controlled by the new `create.dir` argument (#5489).
 

R/guide-bins.R

@@ -376,14 +376,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)))

R/guide-legend.R

@@ -469,7 +469,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)
     }
@@ -503,7 +505,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
     )
@@ -728,37 +730,51 @@ 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
+}

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", {