Stretching legends

R/backports.R

@@ -17,6 +17,26 @@ if (getRversion() < "3.3") {
 
 on_load(backport_unit_methods())
 
+unitType <- function(x) {
+  unit <- attr(x, "unit")
+  if (!is.null(unit)) {
+    return(unit)
+  }
+  if (is.list(x) && is.unit(x[[1]])) {
+    unit <- vapply(x, unitType, character(1))
+    return(unit)
+  } else if ("fname" %in% names(x)) {
+    return(x$fname)
+  }
+  rep("", length(x)) # we're only interested in simple units for now
+}
+
+on_load({
+  if ("unitType" %in% getNamespaceExports("grid")) {
+    unitType <- grid::unitType
+  }
+})
+
 # isFALSE() and isTRUE() are available on R (>=3.5)
 if (getRversion() < "3.5") {
   isFALSE <- function(x) is.logical(x) && length(x) == 1L && !is.na(x) && !x

R/guide-colorbar.R

@@ -15,12 +15,11 @@ NULL
 #' see [guides()].
 #'
 #' @inheritParams guide_legend
-#' @param barwidth A numeric or a [grid::unit()] object specifying
-#'   the width of the colourbar. Default value is `legend.key.width` or
-#'   `legend.key.size` in [theme()] or theme.
-#' @param barheight A numeric or a [grid::unit()] object specifying
-#'   the height of the colourbar. Default value is `legend.key.height` or
-#'   `legend.key.size` in [theme()] or theme.
+#' @param barwidth,barheight A numeric or [grid::unit()] object specifying the
+#'   width and height of the bar respectively. Default value is derived from
+#'   `legend.key.width`, `legend.key.height` or `legend.key` in [theme()].\cr
+#'   `r lifecycle::badge("experimental")`: optionally a `"null"` unit to stretch
+#'   the bar to the available space.
 #' @param frame A theme object for rendering a frame drawn around the bar.
 #'   Usually, the object of `element_rect()` is expected. If `element_blank()`
 #'   (default), no frame is drawn.
@@ -452,29 +451,29 @@ GuideColourbar <- ggproto(
       )
       grob <- rasterGrob(
         image  = image,
-        width  = elements$key.width,
-        height = elements$key.height,
-        default.units = "cm",
+        width  = 1,
+        height = 1,
+        default.units = "npc",
         gp = gpar(col = NA),
         interpolate = TRUE
       )
     } else{
       if (params$direction == "horizontal") {
-        width  <- elements$key.width / nrow(decor)
-        height <- elements$key.height
+        width  <- 1 / nrow(decor)
+        height <- 1
         x <- (seq(nrow(decor)) - 1) * width
         y <- 0
       } else {
-        width  <- elements$key.width
-        height <- elements$key.height / nrow(decor)
+        width  <- 1
+        height <- 1 / nrow(decor)
         y <- (seq(nrow(decor)) - 1) * height
         x <- 0
       }
       grob <- rectGrob(
         x = x, y = y,
         vjust = 0, hjust = 0,
         width = width, height = height,
-        default.units = "cm",
+        default.units = "npc",
         gp = gpar(col = NA, fill = decor$colour)
       )
     }

R/guide-legend.R

@@ -36,12 +36,11 @@
 #'   (right-aligned) for expressions.
 #' @param label.vjust A numeric specifying vertical justification of the label
 #'   text.
-#' @param keywidth A numeric or a [grid::unit()] object specifying
-#'   the width of the legend key. Default value is `legend.key.width` or
-#'   `legend.key.size` in [theme()].
-#' @param keyheight A numeric or a [grid::unit()] object specifying
-#'   the height of the legend key. Default value is `legend.key.height` or
-#'   `legend.key.size` in [theme()].
+#' @param keywidth,keyheight A numeric or [grid::unit()] object specifying the
+#'   width and height of the legend key respectively. Default value is
+#'   `legend.key.width`, `legend.key.height` or `legend.key` in [theme()].\cr
+#'   `r lifecycle::badge("experimental")`: optionally a `"null"` unit to stretch
+#'   keys to the available space.
 #' @param key.spacing,key.spacing.x,key.spacing.y A numeric or [grid::unit()]
 #'   object specifying the distance between key-label pairs in the horizontal
 #'   direction (`key.spacing.x`), vertical direction (`key.spacing.y`) or both
@@ -603,8 +602,19 @@ GuideLegend <- ggproto(
       # Measure title
       title_width  <- width_cm(grobs$title)
       title_height <- height_cm(grobs$title)
-      extra_width  <- max(0, title_width  - sum(widths))
-      extra_height <- max(0, title_height - sum(heights))
+
+      # Titles are assumed to have sufficient size when keys are null units
+      if (is.unit(params$keywidth) && unitType(params$keywidth) == "null") {
+        extra_width <- 0
+      } else {
+        extra_width  <- max(0, title_width  - sum(widths))
+      }
+      if (is.unit(params$keyheight) && unitType(params$keyheight) == "null") {
+        extra_height <- 0
+      } else {
+        extra_height <- max(0, title_height - sum(heights))
+      }
+
       just  <- with(elements$title, rotate_just(angle, hjust, vjust))
       hjust <- just$hjust
       vjust <- just$vjust
@@ -699,11 +709,19 @@ GuideLegend <- ggproto(
   },
 
   assemble_drawing = function(grobs, layout, sizes, params, elements) {
+    widths <- unit(c(sizes$padding[4], sizes$widths, sizes$padding[2]), "cm")
+    if (is.unit(params$keywidth) && unitType(params$keywidth) == "null") {
+      i <- unique(layout$layout$key_col)
+      widths[i] <- params$keywidth
+    }
 
-    gt <- gtable(
-      widths  = unit(c(sizes$padding[4], sizes$widths, sizes$padding[2]), "cm"),
-      heights = unit(c(sizes$padding[1], sizes$heights, sizes$padding[3]), "cm")
-    )
+    heights <- unit(c(sizes$padding[1], sizes$heights, sizes$padding[3]), "cm")
+    if (is.unit(params$keyheight) && unitType(params$keyheight) == "null") {
+      i <- unique(layout$layout$key_row)
+      heights[i] <- params$keyheight
+    }
+
+    gt <- gtable(widths = widths, heights = heights)
 
     # Add background
     if (!is.zero(elements$background)) {

R/guides-.R

@@ -572,10 +572,12 @@ Guides <- ggproto(
     )
 
     # Measure guides
-    widths  <- lapply(grobs, function(g) sum(g$widths))
-    widths  <- inject(unit.c(!!!widths))
-    heights <- lapply(grobs, function(g) sum(g$heights))
-    heights <- inject(unit.c(!!!heights))
+    widths  <- lapply(grobs, `[[`, "widths")
+    heights <- lapply(grobs, `[[`, "heights")
+
+    # Check whether legends are stretched in some direction
+    stretch_x <- any(unlist(lapply(widths,  unitType)) == "null")
+    stretch_y <- any(unlist(lapply(heights, unitType)) == "null")
 
     # Global justification of the complete legend box
     global_just <- paste0("legend.justification.", position)
@@ -605,6 +607,8 @@ Guides <- ggproto(
     box_xjust <- box_just[1]
     box_yjust <- box_just[2]
 
+    margin <- theme$legend.box.margin %||% margin()
+
     # setting that is different for vertical and horizontal guide-boxes.
     if (identical(theme$legend.box, "horizontal")) {
       # Set justification for each legend within the box
@@ -615,13 +619,23 @@ Guides <- ggproto(
                         height = heightDetails(grobs[[i]]))
         )
       }
-      spacing <- theme$legend.spacing.x
+
+      spacing <- convertWidth(theme$legend.spacing.x, "cm")
+      heights <- unit(height_cm(lapply(heights, sum)), "cm")
+
+      if (stretch_x) {
+        widths   <- redistribute_null_units(widths, spacing, margin, "width")
+        vp_width <- unit(1, "npc")
+      } else {
+        widths   <- inject(unit.c(!!!lapply(widths, sum)))
+        vp_width <- sum(widths, spacing * (length(grobs) - 1L))
+      }
 
       # Set global justification
       vp <- viewport(
         x = global_xjust, y = global_yjust, just = global_just,
         height = max(heights),
-        width  = sum(widths, spacing * (length(grobs) - 1L))
+        width  = vp_width
       )
 
       # Initialise gtable as legends in a row
@@ -643,12 +657,22 @@ Guides <- ggproto(
                         width = widthDetails(grobs[[i]]))
         )
       }
-      spacing <- theme$legend.spacing.y
+
+      spacing <- convertHeight(theme$legend.spacing.y, "cm")
+      widths  <- unit(width_cm(lapply(widths, sum)), "cm")
+
+      if (stretch_y) {
+        heights   <- redistribute_null_units(heights, spacing, margin, "height")
+        vp_height <- unit(1, "npc")
+      } else {
+        heights   <- inject(unit.c(!!!lapply(heights, sum)))
+        vp_height <- sum(heights, spacing * (length(grobs) - 1L))
+      }
 
       # Set global justification
       vp <- viewport(
         x = global_xjust, y = global_yjust, just = global_just,
-        height = sum(heights, spacing * (length(grobs) - 1L)),
+        height = vp_height,
         width =  max(widths)
       )
 
@@ -664,7 +688,6 @@ Guides <- ggproto(
     }
 
     # Add margins around the guide-boxes.
-    margin <- theme$legend.box.margin %||% margin()
     guides <- gtable_add_padding(guides, margin)
 
     # Add legend box background
@@ -678,6 +701,12 @@ Guides <- ggproto(
     )
 
     # Set global margin
+    if (stretch_x) {
+      global_margin[c(2, 4)] <- unit(0, "cm")
+    }
+    if (stretch_y) {
+      global_margin[c(1, 3)] <- unit(0, "cm")
+    }
     guides <- gtable_add_padding(guides, global_margin)
 
     guides$name <- "guide-box"
@@ -793,3 +822,46 @@ validate_guide <- function(guide) {
   }
   cli::cli_abort("Unknown guide: {guide}")
 }
+
+redistribute_null_units <- function(units, spacing, margin, type = "width") {
+
+  has_null <- vapply(units, function(x) any(unitType(x) == "null"), logical(1))
+
+  # Early exit when we needn't bother with null units
+  if (!any(has_null)) {
+    units <- lapply(units, sum)
+    units <- inject(unit.c(!!!units))
+    return(units)
+  }
+
+  # Get spacing between guides and margins in absolute units
+  size    <- switch(type, width = convertWidth, height = convertHeight)
+  spacing <- size(spacing, "cm", valueOnly = TRUE)
+  spacing <- sum(rep(spacing, length(units) - 1))
+  margin  <- switch(type, width = margin[c(2, 4)], height = margin[c(1, 3)])
+  margin  <- sum(size(margin, "cm", valueOnly = TRUE))
+
+  # Get the absolute parts of the unit
+  absolute <- vapply(units, function(u) {
+    u <- absolute.size(u)
+    u <- size(u, "cm", valueOnly = TRUE)
+    sum(u)
+  }, numeric(1))
+  absolute_sum <- sum(absolute) + spacing + margin
+
+  # Get the null parts of the unit
+  relative <- rep(0, length(units))
+  relative[has_null] <- vapply(units[has_null], function(u) {
+    sum(as.numeric(u)[unitType(u) == "null"])
+  }, numeric(1))
+  relative_sum <- sum(relative)
+
+  if (relative_sum == 0) {
+    return(unit(absolute, "cm"))
+  }
+
+  relative <- relative / relative_sum
+  available_space <- unit(1, "npc") - unit(absolute_sum, "cm")
+  relative_space <- available_space * relative
+  relative_space + unit(absolute, "cm")
+}