From 0d592ea2c8037fbc0705c8d20f53374af4c80cdf Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 7 Nov 2023 09:46:09 +0100 Subject: [PATCH 01/12] colourbar size is defined in npcs --- R/guide-colorbar.R | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index 7e71eaba0c..6b5eda2cad 100644 --- a/R/guide-colorbar.R +++ b/R/guide-colorbar.R @@ -460,21 +460,21 @@ 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 } @@ -482,7 +482,7 @@ GuideColourbar <- ggproto( 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) ) } From ea8e85573add605064e84827c545967e6810e4d4 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 7 Nov 2023 11:23:55 +0100 Subject: [PATCH 02/12] backport `unitType` --- R/backports.R | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/R/backports.R b/R/backports.R index 9f9d1f36df..ef0d83545a 100644 --- a/R/backports.R +++ b/R/backports.R @@ -17,6 +17,20 @@ if (getRversion() < "3.3") { on_load(backport_unit_methods()) +unitType <- function(x) { + unit <- attr(x, "unit") + if (!is.null(unit)) { + return(unit) + } + 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 From dc8f940655e18c9d4662609f05f2b542534de80a Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Wed, 8 Nov 2023 16:04:35 +0100 Subject: [PATCH 03/12] guide assembly preserves null units --- R/guide-legend.R | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/R/guide-legend.R b/R/guide-legend.R index 341bee47c8..e10f47e843 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -648,11 +648,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)) { From d2fae2fb0a1488167852f9f552cba8e7b008e22c Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Wed, 8 Nov 2023 16:05:38 +0100 Subject: [PATCH 04/12] Handle null units at guide boxes --- R/guides-.R | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/R/guides-.R b/R/guides-.R index 76bac43de0..fa8a8ae38b 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -523,6 +523,7 @@ Guides <- ggproto( height = heightDetails(grobs[[i]])) ) } + widths <- redistribute_null_units(widths, "width") guides <- gtable_row(name = "guides", grobs = grobs, @@ -540,6 +541,7 @@ Guides <- ggproto( width = widthDetails(grobs[[i]])) ) } + heights <- redistribute_null_units(heights, "height") guides <- gtable_col(name = "guides", grobs = grobs, @@ -678,3 +680,39 @@ validate_guide <- function(guide) { } cli::cli_abort("Unknown guide: {guide}") } + +redistribute_null_units <- function(unit, type = "width") { + if (!any(unitType(unit) %in% c("sum", "max", "min"))) { + return(unit) + } + + # Find out the absolute part of the units + cms <- absolute.size(unit) + cms <- switch( + type, + width = convertWidth( cms, "cm", valueOnly = TRUE), + height = convertHeight(cms, "cm", valueOnly = TRUE) + ) + fixed <- sum(cms) + + # Try to grab the nulls from sum units + nulls <- rep(0, length(unit)) + is_sum <- unitType(unit) == "sum" + nulls[is_sum] <- vapply(unclass(unit)[is_sum], function(x) { + if (is.null(x)) { + return(0) + } + x <- x[[2]] + sum(as.numeric(x[unitType(x) == "null"])) + }, numeric(1)) + # Add the plain nulls not part of sums/min/max + nulls <- nulls + as.numeric(unit) * (unitType(unit) == "null") + null_sum <- sum(nulls) + if (null_sum == 0) { + null_sum <- 1 + } + nulls <- nulls / null_sum + + + (unit(1, "npc") - unit(fixed, "cm")) * nulls + unit(cms, "cm") +} From d722392307089db2d289e36f0a8aeb192f53f75d Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Wed, 8 Nov 2023 16:11:44 +0100 Subject: [PATCH 05/12] set legend size to 1npc during build --- R/plot-build.R | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index 10ffaa9ae5..382bb68a6f 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -192,6 +192,15 @@ ggplot_gtable.ggplot_built <- function(data) { legend_width <- gtable_width(legend_box) legend_height <- gtable_height(legend_box) + relative_height <- unitType(legend_height) == "sum" + relative_width <- unitType(legend_width) == "sum" + if (relative_height) { + legend_height <- unit(1, "npc") + } + if (relative_width) { + legend_width <- unit(1, "npc") + } + # Set the justification of the legend box # First value is xjust, second value is yjust just <- valid.just(theme$legend.justification) @@ -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 (!relative_height) { + legend_box <- gtable_add_rows(legend_box, unit(yjust, 'null')) + legend_box <- gtable_add_rows(legend_box, unit(1 - yjust, 'null'), 0) + } + if (!relative_width) { + legend_box <- gtable_add_cols(legend_box, unit(xjust, 'null'), 0) + legend_box <- gtable_add_cols(legend_box, unit(1 - xjust, 'null')) + } } } From 5a9d4d947c60f85cf5671ac2efcdbfbb2353d294 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Thu, 9 Nov 2023 08:59:31 +0100 Subject: [PATCH 06/12] better unit recognitionin R3.6 --- R/backports.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/R/backports.R b/R/backports.R index ef0d83545a..99cc8b2727 100644 --- a/R/backports.R +++ b/R/backports.R @@ -22,6 +22,12 @@ unitType <- function(x) { 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 } From 394ee5934a8c2af98d454b17ace8292b6628d5a3 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Thu, 9 Nov 2023 11:01:33 +0100 Subject: [PATCH 07/12] smart distribution of null units --- R/guides-.R | 86 ++++++++++++++++++++++++++++++----------------------- 1 file changed, 48 insertions(+), 38 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index fa8a8ae38b..f27ac0656e 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -502,10 +502,8 @@ 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 @@ -513,6 +511,8 @@ Guides <- ggproto( 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,14 +523,16 @@ Guides <- ggproto( height = heightDetails(grobs[[i]])) ) } - widths <- redistribute_null_units(widths, "width") + 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 @@ -541,18 +543,19 @@ Guides <- ggproto( width = widthDetails(grobs[[i]])) ) } - heights <- redistribute_null_units(heights, "height") + 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) @@ -681,38 +684,45 @@ validate_guide <- function(guide) { cli::cli_abort("Unknown guide: {guide}") } -redistribute_null_units <- function(unit, type = "width") { - if (!any(unitType(unit) %in% c("sum", "max", "min"))) { - return(unit) +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) } - # Find out the absolute part of the units - cms <- absolute.size(unit) - cms <- switch( - type, - width = convertWidth( cms, "cm", valueOnly = TRUE), - height = convertHeight(cms, "cm", valueOnly = TRUE) - ) - fixed <- sum(cms) - - # Try to grab the nulls from sum units - nulls <- rep(0, length(unit)) - is_sum <- unitType(unit) == "sum" - nulls[is_sum] <- vapply(unclass(unit)[is_sum], function(x) { - if (is.null(x)) { - return(0) - } - x <- x[[2]] - sum(as.numeric(x[unitType(x) == "null"])) + # 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)) - # Add the plain nulls not part of sums/min/max - nulls <- nulls + as.numeric(unit) * (unitType(unit) == "null") - null_sum <- sum(nulls) - if (null_sum == 0) { - null_sum <- 1 - } - nulls <- nulls / null_sum + 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")) + } - (unit(1, "npc") - unit(fixed, "cm")) * nulls + unit(cms, "cm") + relative <- relative / relative_sum + available_space <- unit(1, "npc") - unit(absolute_sum, "cm") + relative_space <- available_space * relative + relative_space + unit(absolute, "cm") } From 44fd15df27ed1127e33d10fb0ab448cff4b5c20b Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Thu, 9 Nov 2023 11:02:14 +0100 Subject: [PATCH 08/12] better detection of relative legend sizes --- R/plot-build.R | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index 382bb68a6f..34495e7301 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -189,16 +189,16 @@ 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) - relative_height <- unitType(legend_height) == "sum" - relative_width <- unitType(legend_width) == "sum" - if (relative_height) { - legend_height <- unit(1, "npc") + if (any(unitType(legend_box$widths) == "sum")) { + legend_width <- unit(1, "npc") + } else { + legend_width <- gtable_width(legend_box) } - if (relative_width) { - legend_width <- unit(1, "npc") + 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 @@ -234,11 +234,11 @@ ggplot_gtable.ggplot_built <- function(data) { width = legend_width ) ) - if (!relative_height) { + 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 (!relative_width) { + 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')) } From 52eafacad67b3495690bdebf7445444bea4f33f0 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Thu, 9 Nov 2023 11:21:34 +0100 Subject: [PATCH 09/12] document use of null units --- R/guide-colorbar.R | 11 +++++------ R/guide-legend.R | 11 +++++------ man/guide_bins.Rd | 12 +++++------- man/guide_colourbar.Rd | 12 +++++------- man/guide_coloursteps.Rd | 11 +++++------ man/guide_legend.Rd | 12 +++++------- 6 files changed, 30 insertions(+), 39 deletions(-) diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index 6b5eda2cad..8c572eda37 100644 --- a/R/guide-colorbar.R +++ b/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. diff --git a/R/guide-legend.R b/R/guide-legend.R index e10f47e843..c25e3e6618 100644 --- a/R/guide-legend.R +++ b/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()] diff --git a/man/guide_bins.Rd b/man/guide_bins.Rd index 6eeada9598..428a5a9cbc 100644 --- a/man/guide_bins.Rd +++ b/man/guide_bins.Rd @@ -70,13 +70,11 @@ label text. The default for standard text is 0 (left-aligned) and 1 \item{label.vjust}{A numeric specifying vertical justification of the label text.} -\item{keywidth}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying -the width of the legend key. Default value is \code{legend.key.width} or -\code{legend.key.size} in \code{\link[=theme]{theme()}}.} - -\item{keyheight}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying -the height of the legend key. Default value is \code{legend.key.height} or -\code{legend.key.size} in \code{\link[=theme]{theme()}}.} +\item{keywidth, keyheight}{A numeric or \code{\link[grid:unit]{grid::unit()}} object specifying the +width and height of the legend key respectively. Default value is +\code{legend.key.width}, \code{legend.key.height} or \code{legend.key} in \code{\link[=theme]{theme()}}.\cr +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}: optionally a \code{"null"} unit to stretch +keys to the available space.} \item{axis}{A theme object for rendering a small axis along the guide. Usually, the object of \code{element_line()} is expected (default). If diff --git a/man/guide_colourbar.Rd b/man/guide_colourbar.Rd index 7813c12b1c..a7de4fcd89 100644 --- a/man/guide_colourbar.Rd +++ b/man/guide_colourbar.Rd @@ -109,13 +109,11 @@ label text. The default for standard text is 0 (left-aligned) and 1 \item{label.vjust}{A numeric specifying vertical justification of the label text.} -\item{barwidth}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying -the width of the colourbar. Default value is \code{legend.key.width} or -\code{legend.key.size} in \code{\link[=theme]{theme()}} or theme.} - -\item{barheight}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying -the height of the colourbar. Default value is \code{legend.key.height} or -\code{legend.key.size} in \code{\link[=theme]{theme()}} or theme.} +\item{barwidth, barheight}{A numeric or \code{\link[grid:unit]{grid::unit()}} object specifying the +width and height of the bar respectively. Default value is derived from +\code{legend.key.width}, \code{legend.key.height} or \code{legend.key} in \code{\link[=theme]{theme()}}.\cr +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}: optionally a \code{"null"} unit to stretch +the bar to the available space.} \item{nbin}{A numeric specifying the number of bins for drawing the colourbar. A smoother colourbar results from a larger value.} diff --git a/man/guide_coloursteps.Rd b/man/guide_coloursteps.Rd index e97230b6f4..96bb9d17b8 100644 --- a/man/guide_coloursteps.Rd +++ b/man/guide_coloursteps.Rd @@ -38,12 +38,11 @@ be a logical which translates \code{TRUE} to \code{element_line()} and \code{FAL \item{...}{ Arguments passed on to \code{\link[=guide_colourbar]{guide_colourbar}} \describe{ - \item{\code{barwidth}}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying -the width of the colourbar. Default value is \code{legend.key.width} or -\code{legend.key.size} in \code{\link[=theme]{theme()}} or theme.} - \item{\code{barheight}}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying -the height of the colourbar. Default value is \code{legend.key.height} or -\code{legend.key.size} in \code{\link[=theme]{theme()}} or theme.} + \item{\code{barwidth,barheight}}{A numeric or \code{\link[grid:unit]{grid::unit()}} object specifying the +width and height of the bar respectively. Default value is derived from +\code{legend.key.width}, \code{legend.key.height} or \code{legend.key} in \code{\link[=theme]{theme()}}.\cr +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}: optionally a \code{"null"} unit to stretch +the bar to the available space.} \item{\code{frame}}{A theme object for rendering a frame drawn around the bar. Usually, the object of \code{element_rect()} is expected. If \code{element_blank()} (default), no frame is drawn.} diff --git a/man/guide_legend.Rd b/man/guide_legend.Rd index 21dcbe7833..ddf474cf74 100644 --- a/man/guide_legend.Rd +++ b/man/guide_legend.Rd @@ -66,13 +66,11 @@ label text. The default for standard text is 0 (left-aligned) and 1 \item{label.vjust}{A numeric specifying vertical justification of the label text.} -\item{keywidth}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying -the width of the legend key. Default value is \code{legend.key.width} or -\code{legend.key.size} in \code{\link[=theme]{theme()}}.} - -\item{keyheight}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying -the height of the legend key. Default value is \code{legend.key.height} or -\code{legend.key.size} in \code{\link[=theme]{theme()}}.} +\item{keywidth, keyheight}{A numeric or \code{\link[grid:unit]{grid::unit()}} object specifying the +width and height of the legend key respectively. Default value is +\code{legend.key.width}, \code{legend.key.height} or \code{legend.key} in \code{\link[=theme]{theme()}}.\cr +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}: optionally a \code{"null"} unit to stretch +keys to the available space.} \item{direction}{A character string indicating the direction of the guide. One of "horizontal" or "vertical."} From beb6e645773d506ed70050c0181dfce11a66e479 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Thu, 9 Nov 2023 11:21:49 +0100 Subject: [PATCH 10/12] Add tests --- .../theme/stretched-horizontal-legends.svg | 90 +++++++++++++++++++ .../theme/stretched-vertical-legends.svg | 90 +++++++++++++++++++ tests/testthat/test-theme.R | 33 +++++++ 3 files changed, 213 insertions(+) create mode 100644 tests/testthat/_snaps/theme/stretched-horizontal-legends.svg create mode 100644 tests/testthat/_snaps/theme/stretched-vertical-legends.svg diff --git a/tests/testthat/_snaps/theme/stretched-horizontal-legends.svg b/tests/testthat/_snaps/theme/stretched-horizontal-legends.svg new file mode 100644 index 0000000000..daa1c3c43e --- /dev/null +++ b/tests/testthat/_snaps/theme/stretched-horizontal-legends.svg @@ -0,0 +1,90 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +x +y + + +a + + + + + + +a +b +c + +x + + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +stretched horizontal legends + + diff --git a/tests/testthat/_snaps/theme/stretched-vertical-legends.svg b/tests/testthat/_snaps/theme/stretched-vertical-legends.svg new file mode 100644 index 0000000000..8fa4c8a8b6 --- /dev/null +++ b/tests/testthat/_snaps/theme/stretched-vertical-legends.svg @@ -0,0 +1,90 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +x +y + + +a + + + + + + +a +b +c + +x + + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +stretched vertical legends + + diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index e6e6cfdb55..a7290289f1 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -704,3 +704,36 @@ test_that("Strips can render custom elements", { theme(strip.text = element_test()) expect_doppelganger("custom strip elements can render", plot) }) + +test_that("legend margins are correct when using relative key sizes", { + + df <- data_frame(x = 1:3, y = 1:3, a = letters[1:3]) + p <- ggplot(df, aes(x, y, colour = x, shape = a)) + + geom_point() + + theme_test() + + theme( + legend.box.background = element_rect(colour = "blue", fill = NA), + legend.background = element_rect(colour = "red", fill = NA) + ) + + vertical <- p + guides( + colour = guide_colourbar(barheight = unit(1, "null")), + shape = guide_legend(keyheight = unit(1/3, "null")) + ) + theme( + legend.box.margin = margin(t = 5, b = 10, unit = "mm"), + legend.margin = margin(t = 10, b = 5, unit = "mm") + ) + + expect_doppelganger("stretched vertical legends", vertical) + + horizontal <- p + guides( + colour = guide_colourbar(barwidth = unit(1, "null")), + shape = guide_legend(keywidth = unit(1/3, "null")) + ) + theme( + legend.position = "top", + legend.box.margin = margin(l = 5, r = 10, unit = "mm"), + legend.margin = margin(l = 10, r = 5, unit = "mm") + ) + + expect_doppelganger("stretched horizontal legends", horizontal) +}) From 6da4b2bc54b1783bb48df2f30605502d685d7f2e Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 11 Dec 2023 14:20:08 +0100 Subject: [PATCH 11/12] Adapt to #5488 --- R/guides-.R | 33 ++++++++++++++++++++++++++++----- 1 file changed, 28 insertions(+), 5 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index 510f2a1d3b..4558f1e821 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -575,6 +575,10 @@ Guides <- ggproto( 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) global_just <- valid.just(calc_element(global_just, theme)) @@ -617,14 +621,21 @@ Guides <- ggproto( } spacing <- convertWidth(theme$legend.spacing.x, "cm") - widths <- redistribute_null_units(widths, spacing, margin, "width") 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 @@ -648,13 +659,20 @@ Guides <- ggproto( } spacing <- convertHeight(theme$legend.spacing.y, "cm") - heights <- redistribute_null_units(heights, spacing, margin, "height") 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) ) @@ -670,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 @@ -684,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" From 2be4e919a74bf0bbf15f57e7f033e93d58ada461 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 11 Dec 2023 15:11:43 +0100 Subject: [PATCH 12/12] Fix title spacing bug --- R/guide-legend.R | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/R/guide-legend.R b/R/guide-legend.R index 43a4625bf3..324e5b81f7 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -602,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