combine glyph layers into a single key earlier

Author: teunbrand

R/guide-legend.R

@@ -271,7 +271,6 @@ GuideLegend <- ggproto(
       c("horizontal", "vertical"), arg_nm = "direction"
     )
     params$n_breaks <- n_breaks <- nrow(params$key)
-    params$n_key_layers <- length(params$decor) + 1 # +1 is key background
 
     # Resolve shape
     if (!is.null(params$nrow) && !is.null(params$ncol) &&
@@ -387,22 +386,30 @@ GuideLegend <- ggproto(
 
   build_decor = function(decor, grobs, elements, params) {
 
-    key_size <- c(elements$width_cm, elements$height_cm) * 10
-
-    draw <- function(i) {
-      bg <- elements$key
-      keys <- lapply(decor, function(g) {
-        data <- vec_slice(g$data, i)
-        if (data$.draw %||% TRUE) {
-          key <- g$draw_key(data, g$params, key_size)
-          set_key_size(key, data$linewidth, data$size, key_size / 10)
-        } else {
-          zeroGrob()
+    key_size <- c(elements$width_cm, elements$height_cm)
+    idx <- seq_len(params$n_breaks)
+
+    key_glyphs <- lapply(idx, function(i) {
+      glyph <- lapply(decor, function(dec) {
+        data <- vec_slice(dec$data, i)
+        if (!(data$.draw %||% TRUE)) {
+          return(zeroGrob())
         }
+        key <- dec$draw_key(data, dec$params, key_size * 10)
+        set_key_size(key, data$linewidth, data$size, key_size)
       })
-      c(list(bg), keys)
-    }
-    unlist(lapply(seq_len(params$n_breaks), draw), FALSE)
+
+      width  <- vapply(glyph, get_attr, which = "width", default = 0, numeric(1))
+      width  <- max(width, 0, key_size[1], na.rm = TRUE)
+      height <- vapply(glyph, get_attr, which = "height", default = 0, numeric(1))
+      height <- max(height, 0, key_size[2], na.rm = TRUE)
+
+      grob <- gTree(children = inject(gList(elements$key, !!!glyph)))
+      attr(grob, "width")  <- width
+      attr(grob, "height") <- height
+      grob
+    })
+    key_glyphs
   },
 
   build_labels = function(key, elements, params) {
@@ -791,3 +798,7 @@ deprecated_guide_args <- function(
   }
   theme
 }
+
+get_attr <- function(x, which, exact = TRUE, default = NULL) {
+  attr(x, which = which, exact = exact) %||% default
+}