diff --git a/R/backports.R b/R/backports.R index 0fe48cc3ac..c19197e09b 100644 --- a/R/backports.R +++ b/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 diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index 374f8ac92e..df2362b717 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. @@ -452,21 +451,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 } @@ -474,7 +473,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) ) } diff --git a/R/guide-legend.R b/R/guide-legend.R index 74c6547e71..324e5b81f7 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 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)) { diff --git a/R/guides-.R b/R/guides-.R index c44fc06907..4558f1e821 100644 --- a/R/guides-.R +++ b/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") +} diff --git a/man/guide_bins.Rd b/man/guide_bins.Rd index 811037d474..59faaa8050 100644 --- a/man/guide_bins.Rd +++ b/man/guide_bins.Rd @@ -71,13 +71,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 8273ec4326..045396216e 100644 --- a/man/guide_colourbar.Rd +++ b/man/guide_colourbar.Rd @@ -111,13 +111,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 d77895415e..4a8b42bdd9 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 75e965adfc..bfd498defc 100644 --- a/man/guide_legend.Rd +++ b/man/guide_legend.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{key.spacing, key.spacing.x, key.spacing.y}{A numeric or \code{\link[grid:unit]{grid::unit()}} object specifying the distance between key-label pairs in the horizontal 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 af6a4b670a..dcaba82966 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -793,3 +793,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) +})