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.
@@ -460,29 +459,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 direction  A character string indicating the direction of the guide.
 #'   One of "horizontal" or "vertical."
 #' @param default.unit A character string indicating [grid::unit()]
@@ -648,11 +647,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

@@ -502,17 +502,17 @@ Guides <- ggproto(
     theme$legend.spacing.x <- theme$legend.spacing.x  %||% theme$legend.spacing
 
     # 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")
 
     # Set the justification of each legend within the legend box
     # First value is xjust, second value is yjust
     just <- valid.just(theme$legend.box.just)
     xjust <- just[1]
     yjust <- 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
@@ -523,13 +523,16 @@ Guides <- ggproto(
                         height = heightDetails(grobs[[i]]))
         )
       }
+      spacing <- convertWidth(theme$legend.spacing.x, "cm")
+      widths  <- redistribute_null_units(widths, spacing, margin, "width")
+      heights <- unit(height_cm(lapply(heights, sum)), "cm")
 
       guides <- gtable_row(name = "guides",
                            grobs = grobs,
                            widths = widths, height = max(heights))
 
       # add space between the guide-boxes
-      guides <- gtable_add_col_space(guides, theme$legend.spacing.x)
+      guides <- gtable_add_col_space(guides, spacing)
 
     } else { # theme$legend.box == "vertical"
       # Set justification for each legend
@@ -540,17 +543,19 @@ Guides <- ggproto(
                         width = widthDetails(grobs[[i]]))
         )
       }
+      spacing <- convertHeight(theme$legend.spacing.y, "cm")
+      heights <- redistribute_null_units(heights, spacing, margin, "height")
+      widths  <- unit(width_cm(lapply(widths, sum)), "cm")
 
       guides <- gtable_col(name = "guides",
                            grobs = grobs,
                            width = max(widths), heights = heights)
 
       # add space between the guide-boxes
-      guides <- gtable_add_row_space(guides, theme$legend.spacing.y)
+      guides <- gtable_add_row_space(guides, spacing)
     }
 
     # Add margins around the guide-boxes.
-    margin <- theme$legend.box.margin %||% margin()
     guides <- gtable_add_cols(guides, margin[4], pos = 0)
     guides <- gtable_add_cols(guides, margin[2], pos = ncol(guides))
     guides <- gtable_add_rows(guides, margin[1], pos = 0)
@@ -678,3 +683,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")
+}

R/plot-build.R

@@ -189,8 +189,17 @@ ggplot_gtable.ggplot_built <- function(data) {
     position <- "none"
   } else {
     # these are a bad hack, since it modifies the contents of viewpoint directly...
-    legend_width  <- gtable_width(legend_box)
-    legend_height <- gtable_height(legend_box)
+
+    if (any(unitType(legend_box$widths) == "sum")) {
+      legend_width  <- unit(1, "npc")
+    } else {
+      legend_width <- gtable_width(legend_box)
+    }
+    if (any(unitType(legend_box$heights) == "sum")) {
+      legend_height <- unit(1, "npc")
+    } else {
+      legend_height <- gtable_height(legend_box)
+    }
 
     # Set the justification of the legend box
     # First value is xjust, second value is yjust
@@ -225,10 +234,14 @@ ggplot_gtable.ggplot_built <- function(data) {
           width = legend_width
         )
       )
-      legend_box <- gtable_add_rows(legend_box, unit(yjust, 'null'))
-      legend_box <- gtable_add_rows(legend_box, unit(1 - yjust, 'null'), 0)
-      legend_box <- gtable_add_cols(legend_box, unit(xjust, 'null'), 0)
-      legend_box <- gtable_add_cols(legend_box, unit(1 - xjust, 'null'))
+      if (unitType(legend_height) != "npc") {
+        legend_box <- gtable_add_rows(legend_box, unit(yjust, 'null'))
+        legend_box <- gtable_add_rows(legend_box, unit(1 - yjust, 'null'), 0)
+      }
+      if (unitType(legend_width) != "npc") {
+        legend_box <- gtable_add_cols(legend_box, unit(xjust, 'null'), 0)
+        legend_box <- gtable_add_cols(legend_box, unit(1 - xjust, 'null'))
+      }
     }
   }