From 2cbfd11307330321d8086450f2c40f9b10b3efdd Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 17 Oct 2023 11:05:57 +0200 Subject: [PATCH 01/35] Add legends in all positions --- R/plot-build.R | 194 +++++++++++++++++++++++++++++-------------------- 1 file changed, 115 insertions(+), 79 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index 2c1695e350..2d984308d2 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -180,85 +180,7 @@ ggplot_gtable.ggplot_built <- function(data) { legend_box <- plot$guides$build( plot$scales, plot$layers, plot$mapping, position, theme, plot$labels ) - - if (is.zero(legend_box)) { - 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) - - # Set the justification of the legend box - # First value is xjust, second value is yjust - just <- valid.just(theme$legend.justification) - xjust <- just[1] - yjust <- just[2] - - if (position == "manual") { - xpos <- theme$legend.position[1] - ypos <- theme$legend.position[2] - - # x and y are specified via theme$legend.position (i.e., coords) - legend_box <- editGrob( - legend_box, - vp = viewport( - x = xpos, - y = ypos, - just = c(xjust, yjust), - height = legend_height, - width = legend_width - ) - ) - } else { - # x and y are adjusted using justification of legend box (i.e., theme$legend.justification) - legend_box <- editGrob( - legend_box, - vp = viewport( - x = xjust, - y = yjust, - just = c(xjust, yjust), - height = legend_height, - 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')) - } - } - - panel_dim <- find_panel(plot_table) - # for align-to-device, use this: - # panel_dim <- summarise(plot_table$layout, t = min(t), r = max(r), b = max(b), l = min(l)) - - theme$legend.box.spacing <- theme$legend.box.spacing %||% unit(0.2, 'cm') - if (position == "left") { - plot_table <- gtable_add_cols(plot_table, theme$legend.box.spacing, pos = 0) - plot_table <- gtable_add_cols(plot_table, legend_width, pos = 0) - plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off", - t = panel_dim$t, b = panel_dim$b, l = 1, r = 1, name = "guide-box") - } else if (position == "right") { - plot_table <- gtable_add_cols(plot_table, theme$legend.box.spacing, pos = -1) - plot_table <- gtable_add_cols(plot_table, legend_width, pos = -1) - plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off", - t = panel_dim$t, b = panel_dim$b, l = -1, r = -1, name = "guide-box") - } else if (position == "bottom") { - plot_table <- gtable_add_rows(plot_table, theme$legend.box.spacing, pos = -1) - plot_table <- gtable_add_rows(plot_table, legend_height, pos = -1) - plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off", - t = -1, b = -1, l = panel_dim$l, r = panel_dim$r, name = "guide-box") - } else if (position == "top") { - plot_table <- gtable_add_rows(plot_table, theme$legend.box.spacing, pos = 0) - plot_table <- gtable_add_rows(plot_table, legend_height, pos = 0) - plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off", - t = 1, b = 1, l = panel_dim$l, r = panel_dim$r, name = "guide-box") - } else if (position == "manual") { - # should guide box expand whole region or region without margin? - plot_table <- gtable_add_grob(plot_table, legend_box, - t = panel_dim$t, b = panel_dim$b, l = panel_dim$l, r = panel_dim$r, - clip = "off", name = "guide-box") - } + plot_table <- table_add_legends(plot_table, legend_box, theme) # Title title <- element_render(theme, "plot.title", plot$labels$title, margin_y = TRUE) @@ -477,3 +399,117 @@ table_add_tag <- function(table, label, theme) { t = place$t, l = place$l, b = place$b, r = place$r ) } + +# Add the legends to the gtable +table_add_legends <- function(table, legends, theme) { + + if (is.zero(legends)) { + return(table) + } + empty <- vapply(legends, is.zero, logical(1)) + if (all(empty)) { + return(table) + } + + # Extract sizes + widths <- lapply(legends, function(x) unit(gtable_width(x), "pt")) + heights <- lapply(legends, function(x) unit(gtable_height(x), "pt")) + spacing <- theme$legend.box.spacing %||% unit(0.2, "cm") + + # Set the justification of the legend box + # First value is xjust, second value is yjust + just <- valid.just(theme$legend.justification) + xjust <- just[1] + yjust <- just[2] + + + if (!is.zero(legends$manual)) { + legends$manual <- editGrob( + legends$manual, + vp = viewport( + x = theme$legend.position[1], + y = theme$legend.position[2], + just = just, + height = heights$manual, + width = widths$manual + ) + ) + } + + legends[.trbl] <- Map( + box = legends[.trbl], + width = widths[.trbl], + height = heights[.trbl], + f = function(box, width, height) { + if (is.zero(box)) { + return(box) + } + box <- editGrob( + box, + vp = viewport( + x = xjust, y = yjust, just = just, + height = height, width = width + ) + ) + box <- gtable_add_rows(box, unit(yjust, "null")) + box <- gtable_add_rows(box, unit(1 - yjust, "null"), 0) + box <- gtable_add_cols(box, unit(xjust, "null"), 0) + box <- gtable_add_cols(box, unit(1 - xjust, "null")) + box + } + ) + + # If legend is missing, set spacing to zero for that legend + zero <- unit(0, "pt") + spacing <- lapply(legends, function(x) if (is.zero(x)) zero else spacing) + + panels <- find_panel(table) + + # Add right legend + table <- gtable_add_cols(table, spacing$right, pos = -1) + table <- gtable_add_cols(table, widths$right, pos = -1) + table <- gtable_add_grob( + table, legends$right, clip = "off", + t = panels$t, b = panels$b, l = -1, r = -1, + name = "guide-box-right" + ) + + # Add left legend + table <- gtable_add_cols(table, spacing$left, pos = 0) + table <- gtable_add_cols(table, widths$left, pos = 0) + table <- gtable_add_grob( + table, legends$left, clip = "off", + t = panels$t, b = panels$b, l = 1, r = 1, + name = "guide-box-left" + ) + + panels <- find_panel(table) + + # Add bottom legend + table <- gtable_add_rows(table, spacing$bottom, pos = -1) + table <- gtable_add_rows(table, heights$bottom, pos = -1) + table <- gtable_add_grob( + table, legends$bottom, clip = "off", + t = -1, b = -1, l = panels$l, r = panels$r, + name = "guide-box-bottom" + ) + + # Add top legend + table <- gtable_add_rows(table, spacing$top, pos = 0) + table <- gtable_add_rows(table, heights$top, pos = 0) + table <- gtable_add_grob( + table, legends$top, clip = "off", + t = 1, b = 1, l = panels$l, r = panels$r, + name = "guide-box-top" + ) + + # Add manual legend + panels <- find_panel(table) + table <- gtable_add_grob( + table, legends$manual, clip = "off", + t = panels$t, b = panels$b, l = panels$l, r = panels$r, + name = "guide-box-manual" + ) + + table +} From 664913dcdf7cf1b6528be06109651d69657dd6bc Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 17 Oct 2023 11:11:14 +0200 Subject: [PATCH 02/35] Assemble separate guide boxes --- R/guides-.R | 27 ++++++++++++++++++++++----- 1 file changed, 22 insertions(+), 5 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index 2117edda62..7208c7cab0 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -281,9 +281,9 @@ Guides <- ggproto( build = function(self, scales, layers, default_mapping, position, theme, labels) { - position <- legend_position(position) + place <- legend_position(position) no_guides <- zeroGrob() - if (position == "none") { + if (place == "none") { return(no_guides) } @@ -291,11 +291,11 @@ Guides <- ggproto( theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size - default_direction <- if (position == "inside") "vertical" else position + default_direction <- if (place == "inside") "vertical" else place theme$legend.box <- theme$legend.box %||% default_direction theme$legend.direction <- theme$legend.direction %||% default_direction theme$legend.box.just <- theme$legend.box.just %||% switch( - position, + place, inside = c("center", "center"), vertical = c("left", "top"), horizontal = c("center", "top") @@ -326,9 +326,22 @@ Guides <- ggproto( return(no_guides) } + positions <- vapply( + guides$params, + function(p) p$position %||% position, + character(1) + ) + positions <- factor(positions, levels = c(.trbl, "manual")) + # Draw and assemble grobs <- guides$draw(theme) - guides$assemble(grobs, theme) + + # Draw separate box for every position + lapply( + split(grobs, positions), + guides$assemble, + theme = theme + ) }, # Setup routine for resolving and validating guides based on paired scales. @@ -490,6 +503,10 @@ Guides <- ggproto( # Combining multiple guides in a guide box assemble = function(grobs, theme) { + if (is.zero(grobs) || length(grobs) == 0) { + return(zeroGrob()) + } + # Set spacing theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") theme$legend.spacing.y <- theme$legend.spacing.y %||% theme$legend.spacing From e59df5b9845cf3d49f8efaec997f3b931ef9439f Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 17 Oct 2023 11:29:22 +0200 Subject: [PATCH 03/35] Add position argument to guides --- R/guide-bins.R | 5 +++++ R/guide-colorbar.R | 5 +++++ R/guide-legend.R | 7 +++++++ 3 files changed, 17 insertions(+) diff --git a/R/guide-bins.R b/R/guide-bins.R index 63c75bd0bd..7333977fd6 100644 --- a/R/guide-bins.R +++ b/R/guide-bins.R @@ -100,6 +100,7 @@ guide_bins <- function( ticks.length = unit(0.2, "npc"), # general + position = NULL, direction = NULL, default.unit = "line", override.aes = list(), @@ -121,6 +122,9 @@ guide_bins <- function( if (!is.null(title.position)) { title.position <- arg_match0(title.position, .trbl) } + if (!is.null(position)) { + position <- arg_match0(position, c(.trbl, "manual")) + } if (!is.null(direction)) { direction <- arg_match0(direction, c("horizontal", "vertical")) } @@ -169,6 +173,7 @@ guide_bins <- function( ticks_length = ticks.length, # general + position = position, direction = direction, override.aes = rename_aes(override.aes), reverse = reverse, diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index 4917679ebf..c7e60559c8 100644 --- a/R/guide-colorbar.R +++ b/R/guide-colorbar.R @@ -151,6 +151,7 @@ guide_colourbar <- function( draw.llim = TRUE, # general + position = NULL, direction = NULL, default.unit = "line", reverse = FALSE, @@ -171,6 +172,9 @@ guide_colourbar <- function( if (!is.null(title.position)) { title.position <- arg_match0(title.position, .trbl) } + if (!is.null(position)) { + position <- arg_match0(position, c(.trbl, "manual")) + } if (!is.null(direction)) { direction <- arg_match0(direction, c("horizontal", "vertical")) } @@ -240,6 +244,7 @@ guide_colourbar <- function( draw_lim = c(isTRUE(draw.llim), isTRUE(draw.ulim)), # general + position = position, direction = direction, reverse = reverse, order = order, diff --git a/R/guide-legend.R b/R/guide-legend.R index 087e3e6fef..cbe576003b 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -42,6 +42,8 @@ #' @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 position A character string indicating where the legend should be +#' placed relative to the plot panels. #' @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()] @@ -145,6 +147,7 @@ guide_legend <- function( keyheight = NULL, # General + position = NULL, direction = NULL, default.unit = "line", override.aes = list(), @@ -168,6 +171,9 @@ guide_legend <- function( if (!is.null(label.position)) { label.position <- arg_match0(label.position, .trbl) } + if (!is.null(position)) { + position <- arg_match0(position, c(.trbl, "manual")) + } new_guide( # Title @@ -196,6 +202,7 @@ guide_legend <- function( byrow = byrow, reverse = reverse, order = order, + position = position, # Fixed parameters available_aes = "any", From 30da1cd8e217c787f3a31ba9e7ecf1e8d338d224 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 17 Oct 2023 11:29:43 +0200 Subject: [PATCH 04/35] reoxygenate --- man/guide_bins.Rd | 4 ++++ man/guide_colourbar.Rd | 5 +++++ man/guide_coloursteps.Rd | 2 ++ man/guide_legend.Rd | 4 ++++ 4 files changed, 15 insertions(+) diff --git a/man/guide_bins.Rd b/man/guide_bins.Rd index 6eeada9598..811037d474 100644 --- a/man/guide_bins.Rd +++ b/man/guide_bins.Rd @@ -23,6 +23,7 @@ guide_bins( axis.arrow = NULL, ticks = NULL, ticks.length = unit(0.2, "npc"), + position = NULL, direction = NULL, default.unit = "line", override.aes = list(), @@ -98,6 +99,9 @@ re-used as \code{ticks} argument (without arrow).} \item{ticks.length}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying the length of tick marks between the keys.} +\item{position}{A character string indicating where the legend should be +placed relative to the plot panels.} + \item{direction}{A character string indicating the direction of the guide. One of "horizontal" or "vertical."} diff --git a/man/guide_colourbar.Rd b/man/guide_colourbar.Rd index 7813c12b1c..8273ec4326 100644 --- a/man/guide_colourbar.Rd +++ b/man/guide_colourbar.Rd @@ -30,6 +30,7 @@ guide_colourbar( ticks.length = unit(0.2, "npc"), draw.ulim = TRUE, draw.llim = TRUE, + position = NULL, direction = NULL, default.unit = "line", reverse = FALSE, @@ -63,6 +64,7 @@ guide_colorbar( ticks.length = unit(0.2, "npc"), draw.ulim = TRUE, draw.llim = TRUE, + position = NULL, direction = NULL, default.unit = "line", reverse = FALSE, @@ -159,6 +161,9 @@ be visible.} \item{draw.llim}{A logical specifying if the lower limit tick marks should be visible.} +\item{position}{A character string indicating where the legend should be +placed relative to the plot panels.} + \item{direction}{A character string indicating the direction of the guide. One of "horizontal" or "vertical."} diff --git a/man/guide_coloursteps.Rd b/man/guide_coloursteps.Rd index e97230b6f4..d77895415e 100644 --- a/man/guide_coloursteps.Rd +++ b/man/guide_coloursteps.Rd @@ -96,6 +96,8 @@ label text. The default for standard text is 0 (left-aligned) and 1 (right-aligned) for expressions.} \item{\code{label.vjust}}{A numeric specifying vertical justification of the label text.} + \item{\code{position}}{A character string indicating where the legend should be +placed relative to the plot panels.} \item{\code{order}}{positive integer less than 99 that specifies the order of this guide among multiple guides. This controls the order in which multiple guides are displayed, not the contents of the guide itself. diff --git a/man/guide_legend.Rd b/man/guide_legend.Rd index 21dcbe7833..6eedabc894 100644 --- a/man/guide_legend.Rd +++ b/man/guide_legend.Rd @@ -17,6 +17,7 @@ guide_legend( label.vjust = NULL, keywidth = NULL, keyheight = NULL, + position = NULL, direction = NULL, default.unit = "line", override.aes = list(), @@ -74,6 +75,9 @@ the width of the legend key. Default value is \code{legend.key.width} or the height of the legend key. Default value is \code{legend.key.height} or \code{legend.key.size} in \code{\link[=theme]{theme()}}.} +\item{position}{A character string indicating where the legend should be +placed relative to the plot panels.} + \item{direction}{A character string indicating the direction of the guide. One of "horizontal" or "vertical."} From df5932811dd529f0f641cd1949b6f36e1dd52917 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 17 Oct 2023 11:30:03 +0200 Subject: [PATCH 05/35] adapt tests --- tests/testthat/test-guides.R | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index 65ff1a6b4d..d7682cea7a 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -51,22 +51,21 @@ test_that("Colorbar respects show.legend in layer", { df <- data_frame(x = 1:3, y = 1) p <- ggplot(df, aes(x = x, y = y, color = x)) + geom_point(size = 20, shape = 21, show.legend = FALSE) - expect_false("guide-box" %in% ggplotGrob(p)$layout$name) + expect_false(any(grepl("guide-box", ggplotGrob(p)$layout$name))) p <- ggplot(df, aes(x = x, y = y, color = x)) + geom_point(size = 20, shape = 21, show.legend = TRUE) - expect_true("guide-box" %in% ggplotGrob(p)$layout$name) + expect_true(any(grepl("guide-box", ggplotGrob(p)$layout$name))) }) test_that("show.legend handles named vectors", { n_legends <- function(p) { g <- ggplotGrob(p) - gb <- which(g$layout$name == "guide-box") - if (length(gb) > 0) { - n <- length(g$grobs[[gb]]) - 1 - } else { - n <- 0 - } - n + gb <- grep("guide-box", g$layout$name) + n <- vapply(g$grobs[gb], function(x) { + if (is.zero(x)) return(0) + length(x$grobs) - 1 + }, numeric(1)) + sum(n) } df <- data_frame(x = 1:3, y = 20:22) From 73d98c5d5058d376626d0d1e9ff231d47e469ed6 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 17 Oct 2023 12:33:22 +0200 Subject: [PATCH 06/35] deal with old R units --- R/plot-build.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index 2d984308d2..6c8e480c6c 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -412,8 +412,12 @@ table_add_legends <- function(table, legends, theme) { } # Extract sizes - widths <- lapply(legends, function(x) unit(gtable_width(x), "pt")) - heights <- lapply(legends, function(x) unit(gtable_height(x), "pt")) + widths <- heights <- set_names( + rep(list(unit(0, "pt")), length(legends)), + names(legends) + ) + widths[!empty] <- lapply(legends[!empty], gtable_width) + heights[!empty] <- lapply(legends[!empty], gtable_height) spacing <- theme$legend.box.spacing %||% unit(0.2, "cm") # Set the justification of the legend box From b2f5a431cf1440e011291dc071defa6b3434aa3f Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 31 Oct 2023 14:54:33 +0100 Subject: [PATCH 07/35] rename manual position to "inside" --- R/plot-build.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index 2d0e891fcd..3f88650b56 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -431,15 +431,15 @@ table_add_legends <- function(table, legends, theme) { yjust <- just[2] - if (!is.zero(legends$manual)) { - legends$manual <- editGrob( - legends$manual, + if (!is.zero(legends$inside)) { + legends$inside <- editGrob( + legends$inside, vp = viewport( x = theme$legend.position[1], y = theme$legend.position[2], just = just, - height = heights$manual, - width = widths$manual + height = heights$inside, + width = widths$inside ) ) } From f7a3f3077cff9cd5a2a01ab0da8e1570b2303fdd Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 31 Oct 2023 14:55:05 +0100 Subject: [PATCH 08/35] resolve spacing once --- R/guides-.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index 7e9ab3d4f2..49501b3dc0 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -509,6 +509,11 @@ Guides <- ggproto( MoreArgs = list(theme = theme) ) + # Set spacing + theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") + theme$legend.spacing.y <- theme$legend.spacing.y %||% theme$legend.spacing + theme$legend.spacing.x <- theme$legend.spacing.x %||% theme$legend.spacing + Map( grobs = grobs, position = levels(positions), @@ -538,11 +543,6 @@ Guides <- ggproto( top = , bottom = c("center", "top") ) - # Set spacing - theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") - theme$legend.spacing.y <- theme$legend.spacing.y %||% theme$legend.spacing - 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)) From e50017b577243064e77509e4bb9742b069978f43 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 31 Oct 2023 15:13:42 +0100 Subject: [PATCH 09/35] omit 'inside' option in justification --- R/guides-.R | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index 49501b3dc0..bfe0dd6d12 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -537,10 +537,9 @@ Guides <- ggproto( theme$legend.box <- theme$legend.box %||% direction theme$legend.direction <- theme$legend.direction %||% direction theme$legend.box.just <- theme$legend.box.just %||% switch( - position, - inside = c("center", "center"), - left = , right = c("left", "top"), - top = , bottom = c("center", "top") + direction, + vertical = c("left", "top"), + horizontal = c("center", "top") ) # Measure guides From bd917cf7d77bc821fbeb1bf1efa13eb6bf6b92af Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 31 Oct 2023 15:47:55 +0100 Subject: [PATCH 10/35] Move more responsibility to `Guides$draw()` --- R/guides-.R | 57 +++++++++++++++++++++++++---------------------------- 1 file changed, 27 insertions(+), 30 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index bfe0dd6d12..2b8c6b4035 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -459,29 +459,10 @@ Guides <- ggproto( }, # Loop over every guide, let them draw their grobs - draw = function(self, params = self$params, guides = self$guides, - theme, position) { + draw = function(self, theme, params = self$params, guides = self$guides) { if (length(guides) == 0) { return(zeroGrob()) } - direction <- switch( - position, - inside = , left = , right = "vertical", - top = , bottom = "horizontal" - ) - Map( - function(guide, params) guide$draw(theme, position, direction, params), - guide = guides, - params = params - ) - }, - - # Combining multiple guides in a guide box - assemble = function(self, theme) { - - if (length(self$guides) < 1) { - return(zeroGrob()) - } default_position <- theme$legend.position %||% "right" if (length(default_position) == 2) { @@ -490,24 +471,40 @@ Guides <- ggproto( if (default_position == "none") { return(zeroGrob()) } - positions <- vapply( - self$params, - function(p) p$position %||% default_position, - character(1) + params, function(p) p$position[1] %||% default_position, character(1) ) positions <- factor(positions, levels = c(.trbl, "inside")) theme$legend.key.width <- theme$legend.key.width %||% theme$legend.key.size theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size + directions <- rep("vertical", length(positions)) + directions[positions %in% c("top", "bottom")] <- "horizontal" + grobs <- Map( - params = split(self$params, positions), - guides = split(self$guides, positions), - position = levels(positions), - f = self$draw, - MoreArgs = list(theme = theme) + function(guide, params, position, direction) { + guide$draw(theme, position, direction, params) + }, + guide = guides, + params = params, + direction = directions, + position = as.character(positions) ) + split(grobs, positions) + }, + + # Combining multiple guides in a guide box + assemble = function(self, theme) { + + if (length(self$guides) < 1) { + return(zeroGrob()) + } + + theme$legend.key.width <- theme$legend.key.width %||% theme$legend.key.size + theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size + + grobs <- self$draw(theme) # Set spacing theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") @@ -516,7 +513,7 @@ Guides <- ggproto( Map( grobs = grobs, - position = levels(positions), + position = names(grobs), self$package_box, MoreArgs = list(theme = theme) ) From f34bf21621f879d48ea986342c284b1b02d551a6 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 31 Oct 2023 15:51:37 +0100 Subject: [PATCH 11/35] Propagate "manual" -> "inside" rename --- R/guide-bins.R | 2 +- R/guide-colorbar.R | 2 +- R/guide-legend.R | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/guide-bins.R b/R/guide-bins.R index 1ab6997b11..86d3e058b6 100644 --- a/R/guide-bins.R +++ b/R/guide-bins.R @@ -123,7 +123,7 @@ guide_bins <- function( title.position <- arg_match0(title.position, .trbl) } if (!is.null(position)) { - position <- arg_match0(position, c(.trbl, "manual")) + position <- arg_match0(position, c(.trbl, "inside")) } if (!is.null(direction)) { direction <- arg_match0(direction, c("horizontal", "vertical")) diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index e55aa1f039..30288fb50b 100644 --- a/R/guide-colorbar.R +++ b/R/guide-colorbar.R @@ -173,7 +173,7 @@ guide_colourbar <- function( title.position <- arg_match0(title.position, .trbl) } if (!is.null(position)) { - position <- arg_match0(position, c(.trbl, "manual")) + position <- arg_match0(position, c(.trbl, "inside")) } if (!is.null(direction)) { direction <- arg_match0(direction, c("horizontal", "vertical")) diff --git a/R/guide-legend.R b/R/guide-legend.R index 14673b8797..1986f4fe74 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -172,7 +172,7 @@ guide_legend <- function( label.position <- arg_match0(label.position, .trbl) } if (!is.null(position)) { - position <- arg_match0(position, c(.trbl, "manual")) + position <- arg_match0(position, c(.trbl, "inside")) } new_guide( From 0c4dc65003dc831213a3df6b0936d4c0db18f7fa Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 31 Oct 2023 15:54:38 +0100 Subject: [PATCH 12/35] Fallback for inside position --- R/plot-build.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index 3f88650b56..d36f638dde 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -432,11 +432,15 @@ table_add_legends <- function(table, legends, theme) { if (!is.zero(legends$inside)) { + position <- theme$legend.position + if (!is.numeric(position) || length(position) != 2) { + position <- c(0.5, 0.5) + } legends$inside <- editGrob( legends$inside, vp = viewport( - x = theme$legend.position[1], - y = theme$legend.position[2], + x = position[1], + y = position[2], just = just, height = heights$inside, width = widths$inside From ad8e9648facb8ec168cab84ab4dbf9e282c9d321 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 31 Oct 2023 16:56:49 +0100 Subject: [PATCH 13/35] Rearrange methods into logical order --- R/guides-.R | 92 ++++++++++++++++++++++++++++------------------------- 1 file changed, 49 insertions(+), 43 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index 2b8c6b4035..f7ab96fc41 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -250,8 +250,8 @@ Guides <- ggproto( ## Building ------------------------------------------------------------------ - # The `Guides$build()` method is called in ggplotGrob (plot-build.R) and makes - # the guide box for *non-position* scales. + # The `Guides$build()` method is called in ggplot_build (plot-build.R) and + # collects all information needed from the plot. # Note that position scales are handled in `Coord`s, which have their own # procedures to do equivalent steps. # @@ -271,12 +271,7 @@ Guides <- ggproto( # 3. Guides$process_layers() # process layer information and generate geom info. # - # 4. Guides$draw() - # generate guide grob from each guide object - # one guide grob for one guide object - # - # 5. Guides$assemble() - # arrange all guide grobs + # The resulting guide is then drawn in ggplot_gtable build = function(self, scales, layers, labels, layer_data) { @@ -458,7 +453,45 @@ Guides <- ggproto( invisible() }, - # Loop over every guide, let them draw their grobs + # The `Guides$assemble()` method is called in ggplot_gtable (plot-build.R) and + # applies the styling from the theme to render each guide and package them + # into guide boxes. + # + # The procedure is as follows + # + # 1. Guides$draw() + # for every guide object, draw one grob, + # then group the grobs in a list per position + # + # 2. Guides$package_box() + # for every position, collect all individual guides and arrange them + # into a guide box which will be inserted into the main gtable + # Combining multiple guides in a guide box + assemble = function(self, theme) { + + if (length(self$guides) < 1) { + return(zeroGrob()) + } + + theme$legend.key.width <- theme$legend.key.width %||% theme$legend.key.size + theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size + + grobs <- self$draw(theme) + + # Set spacing + theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") + theme$legend.spacing.y <- theme$legend.spacing.y %||% theme$legend.spacing + theme$legend.spacing.x <- theme$legend.spacing.x %||% theme$legend.spacing + + Map( + grobs = grobs, + position = names(grobs), + self$package_box, + MoreArgs = list(theme = theme) + ) + }, + + # Render the guides into grobs draw = function(self, theme, params = self$params, guides = self$guides) { if (length(guides) == 0) { return(zeroGrob()) @@ -482,41 +515,14 @@ Guides <- ggproto( directions <- rep("vertical", length(positions)) directions[positions %in% c("top", "bottom")] <- "horizontal" - grobs <- Map( - function(guide, params, position, direction) { - guide$draw(theme, position, direction, params) - }, - guide = guides, - params = params, - direction = directions, - position = as.character(positions) - ) - split(grobs, positions) - }, - - # Combining multiple guides in a guide box - assemble = function(self, theme) { - - if (length(self$guides) < 1) { - return(zeroGrob()) + grobs <- vector("list", length(guides)) + for (i in seq_along(grobs)) { + grobs[[i]] <- guides[[i]]$draw( + theme = theme, position = as.character(positions[i]), + direction = directions[i], params = params[[i]] + ) } - - theme$legend.key.width <- theme$legend.key.width %||% theme$legend.key.size - theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size - - grobs <- self$draw(theme) - - # Set spacing - theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") - theme$legend.spacing.y <- theme$legend.spacing.y %||% theme$legend.spacing - theme$legend.spacing.x <- theme$legend.spacing.x %||% theme$legend.spacing - - Map( - grobs = grobs, - position = names(grobs), - self$package_box, - MoreArgs = list(theme = theme) - ) + split(grobs, positions) }, package_box = function(grobs, position, theme) { From 759f2af21bd54cbcc09ca6ae04e6f26c0e311b90 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 31 Oct 2023 17:14:24 +0100 Subject: [PATCH 14/35] remove vestigial stuff --- R/plot-build.R | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index d36f638dde..9994d50c56 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -178,11 +178,6 @@ ggplot_gtable.ggplot_built <- function(data) { plot_table <- layout$render(geom_grobs, data, theme, plot$labels) # Legends - position <- theme$legend.position %||% "right" - if (length(position) == 2) { - position <- "manual" - } - legend_box <- plot$guides$assemble(theme) plot_table <- table_add_legends(plot_table, legend_box, theme) @@ -430,7 +425,6 @@ table_add_legends <- function(table, legends, theme) { xjust <- just[1] yjust <- just[2] - if (!is.zero(legends$inside)) { position <- theme$legend.position if (!is.numeric(position) || length(position) != 2) { @@ -463,10 +457,8 @@ table_add_legends <- function(table, legends, theme) { height = height, width = width ) ) - box <- gtable_add_rows(box, unit(yjust, "null")) - box <- gtable_add_rows(box, unit(1 - yjust, "null"), 0) - box <- gtable_add_cols(box, unit(xjust, "null"), 0) - box <- gtable_add_cols(box, unit(1 - xjust, "null")) + margin <- margin(1 - yjust, 1 - xjust, yjust, xjust, unit = "null") + box <- gtable_add_padding(box, margin) box } ) From a1d247130cd0b56db3b0d24350140b9fb8e386d7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Wed, 1 Nov 2023 09:24:58 +0100 Subject: [PATCH 15/35] Separate numeric inside positioning from `legend.position` argument --- R/plot-build.R | 5 +---- R/theme-elements.R | 3 ++- R/theme.R | 15 +++++++++++++-- man/ggplot2-ggproto.Rd | 8 +++++--- man/theme.Rd | 8 ++++++-- 5 files changed, 27 insertions(+), 12 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index 9994d50c56..2d7f210ff0 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -426,10 +426,7 @@ table_add_legends <- function(table, legends, theme) { yjust <- just[2] if (!is.zero(legends$inside)) { - position <- theme$legend.position - if (!is.numeric(position) || length(position) != 2) { - position <- c(0.5, 0.5) - } + position <- theme$legend.position.inside %||% just legends$inside <- editGrob( legends$inside, vp = viewport( diff --git a/R/theme-elements.R b/R/theme-elements.R index 4dda819879..f8ded44e5e 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -502,7 +502,8 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { legend.key.width = el_def(c("unit", "rel"), "legend.key.size"), legend.text = el_def("element_text", "text"), legend.title = el_def("element_text", "title"), - legend.position = el_def(c("character", "numeric", "integer")), + legend.position = el_def("character"), + legend.position.inside = el_def(c("numeric", "integer")), legend.direction = el_def("character"), legend.justification = el_def(c("character", "numeric", "integer")), legend.box = el_def("character"), diff --git a/R/theme.R b/R/theme.R index fd4a445e32..2fc8fb1339 100644 --- a/R/theme.R +++ b/R/theme.R @@ -78,8 +78,10 @@ #' `text`) #' @param legend.title title of legend ([element_text()]; inherits from #' `title`) -#' @param legend.position the position of legends ("none", "left", "right", -#' "bottom", "top", or two-element numeric vector) +#' @param legend.position the default position of legends ("none", "left", +#' "right", "bottom", "top", "inside") +#' @param legend.position.inside A numeric vector of length two setting the +#' placement of legends that have the `"inside"` position. #' @param legend.direction layout of items in legends ("horizontal" or #' "vertical") #' @param legend.justification anchor point for positioning legend inside plot @@ -344,6 +346,7 @@ theme <- function(line, legend.text, legend.title, legend.position, + legend.position.inside, legend.direction, legend.justification, legend.box, @@ -455,6 +458,14 @@ theme <- function(line, } elements$legend.text.align <- NULL } + if (is.numeric(elements$legend.position)) { + deprecate_soft0( + "3.5.0", I("A numeric `legend.position` argument in `theme()`"), + "theme(legend.position.inside)" + ) + elements$legend.position.inside <- elements$legend.position + elements$legend.position <- "inside" + } # If complete theme set all non-blank elements to inherit from blanks if (complete) { diff --git a/man/ggplot2-ggproto.Rd b/man/ggplot2-ggproto.Rd index 37a042dd68..95381ec5bf 100644 --- a/man/ggplot2-ggproto.Rd +++ b/man/ggplot2-ggproto.Rd @@ -421,9 +421,11 @@ range. \item \code{merge()} Combines information from multiple guides with the same \code{params$hash}. This ensures that e.g. \code{guide_legend()} can display both \code{shape} and \code{colour} in the same guide. -\item \code{get_layer_key()} Extract information from layers. This can be used to -check that the guide's aesthetic is actually in use, or to gather -information about how legend keys should be displayed. +\item \code{process_layers()} Extract information from layers. This acts mostly +as a filter for which layers to include and these are then (typically) +forwarded to \code{get_layer_key()}. +\item \code{get_layer_key()} This can be used to gather information about how legend +keys should be displayed. \item \code{setup_params()} Set up parameters at the beginning of drawing stages. It can be used to overrule user-supplied parameters or perform checks on the \code{params} property. diff --git a/man/theme.Rd b/man/theme.Rd index 7672d42c5a..81e9235660 100644 --- a/man/theme.Rd +++ b/man/theme.Rd @@ -68,6 +68,7 @@ theme( legend.text, legend.title, legend.position, + legend.position.inside, legend.direction, legend.justification, legend.box, @@ -184,8 +185,11 @@ inherits from \code{rect})} \item{legend.title}{title of legend (\code{\link[=element_text]{element_text()}}; inherits from \code{title})} -\item{legend.position}{the position of legends ("none", "left", "right", -"bottom", "top", or two-element numeric vector)} +\item{legend.position}{the default position of legends ("none", "left", +"right", "bottom", "top", "inside")} + +\item{legend.position.inside}{A numeric vector of length two setting the +placement of legends that have the \code{"inside"} position.} \item{legend.direction}{layout of items in legends ("horizontal" or "vertical")} From 731b77462aa253b8e0955ae2affb3fad359e6230 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Wed, 1 Nov 2023 10:37:11 +0100 Subject: [PATCH 16/35] Implement plot-wise justification (#4020) --- R/plot-build.R | 33 +++++++++++++++++++++++++-------- R/theme-elements.R | 2 ++ R/theme.R | 4 ++++ man/theme.Rd | 5 +++++ 4 files changed, 36 insertions(+), 8 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index 2d7f210ff0..e1ec38afc4 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -464,14 +464,20 @@ table_add_legends <- function(table, legends, theme) { zero <- unit(0, "pt") spacing <- lapply(legends, function(x) if (is.zero(x)) zero else spacing) - panels <- find_panel(table) + location <- switch( + theme$legend.location %||% "panel", + "plot" = plot_extent, + find_panel + ) + + place <- location(table) # Add right legend table <- gtable_add_cols(table, spacing$right, pos = -1) table <- gtable_add_cols(table, widths$right, pos = -1) table <- gtable_add_grob( table, legends$right, clip = "off", - t = panels$t, b = panels$b, l = -1, r = -1, + t = place$t, b = place$b, l = -1, r = -1, name = "guide-box-right" ) @@ -480,18 +486,18 @@ table_add_legends <- function(table, legends, theme) { table <- gtable_add_cols(table, widths$left, pos = 0) table <- gtable_add_grob( table, legends$left, clip = "off", - t = panels$t, b = panels$b, l = 1, r = 1, + t = place$t, b = place$b, l = 1, r = 1, name = "guide-box-left" ) - panels <- find_panel(table) + place <- location(table) # Add bottom legend table <- gtable_add_rows(table, spacing$bottom, pos = -1) table <- gtable_add_rows(table, heights$bottom, pos = -1) table <- gtable_add_grob( table, legends$bottom, clip = "off", - t = -1, b = -1, l = panels$l, r = panels$r, + t = -1, b = -1, l = place$l, r = place$r, name = "guide-box-bottom" ) @@ -500,17 +506,28 @@ table_add_legends <- function(table, legends, theme) { table <- gtable_add_rows(table, heights$top, pos = 0) table <- gtable_add_grob( table, legends$top, clip = "off", - t = 1, b = 1, l = panels$l, r = panels$r, + t = 1, b = 1, l = place$l, r = place$r, name = "guide-box-top" ) # Add manual legend - panels <- find_panel(table) + place <- find_panel(table) table <- gtable_add_grob( table, legends$inside, clip = "off", - t = panels$t, b = panels$b, l = panels$l, r = panels$r, + t = place$t, b = place$b, l = place$l, r = place$r, name = "guide-box-inside" ) table } + +plot_extent <- function(table) { + layout <- table$layout + data_frame0( + t = min(.subset2(layout, "t")), + r = max(.subset2(layout, "r")), + b = max(.subset2(layout, "b")), + l = min(.subset2(layout, "l")), + .size = 1L + ) +} diff --git a/R/theme-elements.R b/R/theme-elements.R index f8ded44e5e..570a4680b8 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -506,6 +506,8 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { legend.position.inside = el_def(c("numeric", "integer")), legend.direction = el_def("character"), legend.justification = el_def(c("character", "numeric", "integer")), + legend.location = el_def("character"), + legend.box = el_def("character"), legend.box.just = el_def("character"), legend.box.margin = el_def("margin"), diff --git a/R/theme.R b/R/theme.R index 2fc8fb1339..d4ef4b5f89 100644 --- a/R/theme.R +++ b/R/theme.R @@ -87,6 +87,9 @@ #' @param legend.justification anchor point for positioning legend inside plot #' ("center" or two-element numeric vector) or the justification according to #' the plot area when positioned outside the plot +#' @param legend.location Relative placement of legends outside the plot as a +#' string. Can be `"panel"` (default) to align legends to the panels or +#' `"plot"` to align legends to the plot as a whole. #' @param legend.box arrangement of multiple legends ("horizontal" or #' "vertical") #' @param legend.box.just justification of each legend within the overall @@ -349,6 +352,7 @@ theme <- function(line, legend.position.inside, legend.direction, legend.justification, + legend.location, legend.box, legend.box.just, legend.box.margin, diff --git a/man/theme.Rd b/man/theme.Rd index 81e9235660..b4ad6bc852 100644 --- a/man/theme.Rd +++ b/man/theme.Rd @@ -71,6 +71,7 @@ theme( legend.position.inside, legend.direction, legend.justification, + legend.location, legend.box, legend.box.just, legend.box.margin, @@ -198,6 +199,10 @@ placement of legends that have the \code{"inside"} position.} ("center" or two-element numeric vector) or the justification according to the plot area when positioned outside the plot} +\item{legend.location}{Relative placement of legends outside the plot as a +string. Can be \code{"panel"} (default) to align legends to the panels or +\code{"plot"} to align legends to the plot as a whole.} + \item{legend.box}{arrangement of multiple legends ("horizontal" or "vertical")} From 32bc3e0153ac086697462773cd93dca36513ed6a Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Thu, 2 Nov 2023 13:25:37 +0100 Subject: [PATCH 17/35] Partially revert bd917cf --- R/guides-.R | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index f7ab96fc41..6c2e48e9c5 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -473,10 +473,18 @@ Guides <- ggproto( return(zeroGrob()) } + default_position <- theme$legend.position %||% "right" + if (length(default_position) == 2) { + default_position <- "inside" + } + if (default_position == "none") { + return(zeroGrob()) + } + theme$legend.key.width <- theme$legend.key.width %||% theme$legend.key.size theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size - grobs <- self$draw(theme) + grobs <- self$draw(theme, default_position) # Set spacing theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") @@ -492,18 +500,8 @@ Guides <- ggproto( }, # Render the guides into grobs - draw = function(self, theme, params = self$params, guides = self$guides) { - if (length(guides) == 0) { - return(zeroGrob()) - } - - default_position <- theme$legend.position %||% "right" - if (length(default_position) == 2) { - default_position <- "inside" - } - if (default_position == "none") { - return(zeroGrob()) - } + draw = function(self, theme, default_position = "right", + params = self$params, guides = self$guides) { positions <- vapply( params, function(p) p$position[1] %||% default_position, character(1) ) From 8414dfc4d37192f6f34a2e16cdcec70ee3433a2e Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 7 Nov 2023 12:09:08 +0100 Subject: [PATCH 18/35] Add extra justification theme settings --- R/theme-elements.R | 22 ++++++++++++++++++++++ R/theme.R | 5 +++++ 2 files changed, 27 insertions(+) diff --git a/R/theme-elements.R b/R/theme-elements.R index 570a4680b8..d3860b3756 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -505,7 +505,29 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { legend.position = el_def("character"), legend.position.inside = el_def(c("numeric", "integer")), legend.direction = el_def("character"), + legend.justification = el_def(c("character", "numeric", "integer")), + legend.justification.top = el_def( + c("character", "numeric", "integer"), + "legend.justification" + ), + legend.justification.bottom = el_def( + c("character", "numeric", "integer"), + "legend.justification" + ), + legend.justification.left = el_def( + c("character", "numeric", "integer"), + "legend.justification" + ), + legend.justification.right = el_def( + c("character", "numeric", "integer"), + "legend.justification" + ), + legend.justification.inside = el_def( + c("character", "numeric", "integer"), + "legend.justification" + ), + legend.location = el_def("character"), legend.box = el_def("character"), diff --git a/R/theme.R b/R/theme.R index d4ef4b5f89..082d66e331 100644 --- a/R/theme.R +++ b/R/theme.R @@ -352,6 +352,11 @@ theme <- function(line, legend.position.inside, legend.direction, legend.justification, + legend.justification.top, + legend.justification.bottom, + legend.justification.left, + legend.justification.right, + legend.justification.inside, legend.location, legend.box, legend.box.just, From 9b1f54df272650be76bd043ab4779f93bdebc53c Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 7 Nov 2023 12:50:43 +0100 Subject: [PATCH 19/35] Document `legend.justification.{position}` --- R/theme.R | 2 ++ man/theme.Rd | 7 +++++++ 2 files changed, 9 insertions(+) diff --git a/R/theme.R b/R/theme.R index 082d66e331..f7e28fd2d2 100644 --- a/R/theme.R +++ b/R/theme.R @@ -87,6 +87,8 @@ #' @param legend.justification anchor point for positioning legend inside plot #' ("center" or two-element numeric vector) or the justification according to #' the plot area when positioned outside the plot +#' @param legend.justification.top,legend.justification.bottom,legend.justification.left,legend.justification.right,legend.justification.inside +#' Same as `legend.justification` but specified per `legend.position` option. #' @param legend.location Relative placement of legends outside the plot as a #' string. Can be `"panel"` (default) to align legends to the panels or #' `"plot"` to align legends to the plot as a whole. diff --git a/man/theme.Rd b/man/theme.Rd index b4ad6bc852..4304509fa5 100644 --- a/man/theme.Rd +++ b/man/theme.Rd @@ -71,6 +71,11 @@ theme( legend.position.inside, legend.direction, legend.justification, + legend.justification.top, + legend.justification.bottom, + legend.justification.left, + legend.justification.right, + legend.justification.inside, legend.location, legend.box, legend.box.just, @@ -199,6 +204,8 @@ placement of legends that have the \code{"inside"} position.} ("center" or two-element numeric vector) or the justification according to the plot area when positioned outside the plot} +\item{legend.justification.top, legend.justification.bottom, legend.justification.left, legend.justification.right, legend.justification.inside}{Same as \code{legend.justification} but specified per \code{legend.position} option.} + \item{legend.location}{Relative placement of legends outside the plot as a string. Can be \code{"panel"} (default) to align legends to the panels or \code{"plot"} to align legends to the plot as a whole.} From 32a69536e8e4510e39ba2f70b57a93be10d239b2 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 7 Nov 2023 12:51:11 +0100 Subject: [PATCH 20/35] Apply justification --- R/plot-build.R | 49 ++++++++++++++++++++++++------------------------- 1 file changed, 24 insertions(+), 25 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index e1ec38afc4..c39b572fd9 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -419,13 +419,10 @@ table_add_legends <- function(table, legends, theme) { heights[!empty] <- lapply(legends[!empty], gtable_height) spacing <- theme$legend.box.spacing %||% unit(0.2, "cm") - # Set the justification of the legend box - # First value is xjust, second value is yjust - just <- valid.just(theme$legend.justification) - xjust <- just[1] - yjust <- just[2] - if (!is.zero(legends$inside)) { + # Set the justification of the legend box + just <- valid.just(calc_element("legend.justification.inside", theme)) + position <- theme$legend.position.inside %||% just legends$inside <- editGrob( legends$inside, @@ -439,26 +436,28 @@ table_add_legends <- function(table, legends, theme) { ) } - legends[.trbl] <- Map( - box = legends[.trbl], - width = widths[.trbl], - height = heights[.trbl], - f = function(box, width, height) { - if (is.zero(box)) { - return(box) - } - box <- editGrob( - box, - vp = viewport( - x = xjust, y = yjust, just = just, - height = height, width = width - ) - ) - margin <- margin(1 - yjust, 1 - xjust, yjust, xjust, unit = "null") - box <- gtable_add_padding(box, margin) - box + legends[.trbl] <- lapply(.trbl, function(position) { + box <- .subset2(legends, position) + if (is.zero(box)) { + return(box) } - ) + just <- paste0("legend.justification.", position) + just <- valid.just(calc_element(just, theme)) + + # First value is xjust, second value is yjust + xjust <- just[1] + yjust <- just[2] + + margin <- margin(1 - yjust, 1 - xjust, yjust, xjust, unit = "null") + + vp <- viewport( + x = xjust, y = yjust, just = just, + height = heights[position], + width = widths[position] + ) + box <- editGrob(box, vp = vp) + gtable_add_padding(box, margin) + }) # If legend is missing, set spacing to zero for that legend zero <- unit(0, "pt") From bf1afbdc7656a42a0b4d9ac906b2c7c4e86b77df Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 7 Nov 2023 13:48:14 +0100 Subject: [PATCH 21/35] Prevent FP warnings by partial matching --- R/theme.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/theme.R b/R/theme.R index f7e28fd2d2..94a17d43bc 100644 --- a/R/theme.R +++ b/R/theme.R @@ -469,7 +469,7 @@ theme <- function(line, } elements$legend.text.align <- NULL } - if (is.numeric(elements$legend.position)) { + if (is.numeric(.subset2(elements, "legend.position"))) { deprecate_soft0( "3.5.0", I("A numeric `legend.position` argument in `theme()`"), "theme(legend.position.inside)" From 5ffcdf141aa8291761f398732a82c730db6c4fab Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 7 Nov 2023 13:49:11 +0100 Subject: [PATCH 22/35] Switch to new inside position --- tests/testthat/test-guides.R | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index 77e0efaae7..9b6a200098 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -604,18 +604,19 @@ test_that("guides are positioned correctly", { expect_doppelganger("padding in legend box", p2) + p2 <- p2 + theme(legend.position = "inside") # Placement of legend inside expect_doppelganger("legend inside plot, centered", - p2 + theme(legend.position = c(.5, .5)) + p2 + theme(legend.position.inside = c(.5, .5)) ) expect_doppelganger("legend inside plot, bottom left", - p2 + theme(legend.justification = c(0,0), legend.position = c(0,0)) + p2 + theme(legend.justification = c(0,0), legend.position.inside = c(0,0)) ) expect_doppelganger("legend inside plot, top right", - p2 + theme(legend.justification = c(1,1), legend.position = c(1,1)) + p2 + theme(legend.justification = c(1,1), legend.position.inside = c(1,1)) ) expect_doppelganger("legend inside plot, bottom left of legend at center", - p2 + theme(legend.justification = c(0,0), legend.position = c(.5,.5)) + p2 + theme(legend.justification = c(0,0), legend.position.inside = c(.5,.5)) ) }) From 5388165faa5ce61aeaad1d06a0251fb83bad5721 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 7 Nov 2023 13:49:29 +0100 Subject: [PATCH 23/35] Add test for justification per position --- ...egends-at-all-sides-with-justification.svg | 157 ++++++++++++++++++ tests/testthat/test-theme.R | 32 ++++ 2 files changed, 189 insertions(+) create mode 100644 tests/testthat/_snaps/theme/legends-at-all-sides-with-justification.svg diff --git a/tests/testthat/_snaps/theme/legends-at-all-sides-with-justification.svg b/tests/testthat/_snaps/theme/legends-at-all-sides-with-justification.svg new file mode 100644 index 0000000000..9847f9f0c9 --- /dev/null +++ b/tests/testthat/_snaps/theme/legends-at-all-sides-with-justification.svg @@ -0,0 +1,157 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + + + + +100 +200 +300 +400 +disp +mpg + +wt + + + + + + + + +2 +3 +4 +5 + +drat + + + + + + + + +3.0 +3.5 +4.0 +4.5 + +hp + + + + + + + + + + + +100 +150 +200 +250 +300 + +factor(cyl) + + + + + + +4 +6 +8 + +factor(gear) + + + + + + +3 +4 +5 +legends at all sides with justification + + diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index e6e6cfdb55..ed6f92ebca 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -686,6 +686,38 @@ test_that("plot titles and caption can be aligned to entire plot", { }) +test_that("Legends can on all sides of the plot with custom justification", { + + plot <- ggplot(mtcars) + + aes( + disp, mpg, + colour = hp, + fill = factor(gear), + shape = factor(cyl), + size = drat, + alpha = wt + ) + + geom_point() + + guides( + shape = guide_legend(position = "top"), + colour = guide_colourbar(position = "bottom"), + size = guide_legend(position = "left"), + alpha = guide_legend(position = "right"), + fill = guide_legend(position = "inside", override.aes = list(shape = 21)) + ) + + theme_test() + + theme( + legend.justification.top = "left", + legend.justification.bottom = c(1, 0), + legend.justification.left = c(0, 1), + legend.justification.right = "bottom", + legend.justification.inside = c(0.75, 0.75), + legend.location = "plot" + ) + + expect_doppelganger("legends at all sides with justification", plot) +}) + test_that("Strips can render custom elements", { element_test <- function(...) { el <- element_text(...) From 667881723b3dcfa76f72b6606df507d58aefa29c Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 7 Nov 2023 13:49:58 +0100 Subject: [PATCH 24/35] Fix subsetting bug --- R/plot-build.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index c39b572fd9..af5cb336d6 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -452,8 +452,8 @@ table_add_legends <- function(table, legends, theme) { vp <- viewport( x = xjust, y = yjust, just = just, - height = heights[position], - width = widths[position] + height = .subset2(heights, position), + width = .subset2(widths, position) ) box <- editGrob(box, vp = vp) gtable_add_padding(box, margin) From 8508ebc075c4431cd66690af7c97a3ff1e11eb4b Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 21 Nov 2023 12:25:27 +0100 Subject: [PATCH 25/35] always add gtable rows/cols --- R/plot-build.R | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index af5cb336d6..2232f89ea1 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -402,19 +402,16 @@ table_add_tag <- function(table, label, theme) { # Add the legends to the gtable table_add_legends <- function(table, legends, theme) { - if (is.zero(legends)) { - return(table) - } - empty <- vapply(legends, is.zero, logical(1)) - if (all(empty)) { - return(table) - } - # Extract sizes widths <- heights <- set_names( - rep(list(unit(0, "pt")), length(legends)), + rep(list(unit(0, "cm")), length(legends)), names(legends) ) + if (is.zero(legends)) { + legends <- rep(list(zeroGrob()), 5) + names(legends) <- c(.trbl, "inside") + } + empty <- vapply(legends, is.zero, logical(1)) widths[!empty] <- lapply(legends[!empty], gtable_width) heights[!empty] <- lapply(legends[!empty], gtable_height) spacing <- theme$legend.box.spacing %||% unit(0.2, "cm") @@ -461,7 +458,7 @@ table_add_legends <- function(table, legends, theme) { # If legend is missing, set spacing to zero for that legend zero <- unit(0, "pt") - spacing <- lapply(legends, function(x) if (is.zero(x)) zero else spacing) + spacing <- lapply(empty, function(is_empty) if (is_empty) zero else spacing) location <- switch( theme$legend.location %||% "panel", From 76d09f536d5c8f96bf3cabf16e7c891de3607c43 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 21 Nov 2023 12:44:29 +0100 Subject: [PATCH 26/35] adjust table dimension expectations --- tests/testthat/test-facet-strips.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/testthat/test-facet-strips.R b/tests/testthat/test-facet-strips.R index a56f5644cb..b5a2a154ae 100644 --- a/tests/testthat/test-facet-strips.R +++ b/tests/testthat/test-facet-strips.R @@ -154,19 +154,19 @@ test_that("padding is only added if axis is present", { strip.switch.pad.grid = unit(10, "mm") ) pg <- ggplotGrob(p) - expect_equal(length(pg$heights), 13) + expect_equal(length(pg$heights), 15) pg <- ggplotGrob(p + scale_x_continuous(position = "top")) - expect_equal(length(pg$heights), 14) - expect_equal(as.character(pg$heights[7]), "1cm") + expect_equal(length(pg$heights), 16) + expect_equal(as.character(pg$heights[8]), "1cm") # Also add padding with negative ticks and no text (#5251) pg <- ggplotGrob( p + scale_x_continuous(labels = NULL, position = "top") + theme(axis.ticks.length.x.top = unit(-2, "mm")) ) - expect_equal(length(pg$heights), 14) - expect_equal(as.character(pg$heights[7]), "1cm") + expect_equal(length(pg$heights), 16) + expect_equal(as.character(pg$heights[8]), "1cm") }) test_that("y strip labels are rotated when strips are switched", { From 1f08cd489b48524c4cf5e806a6a9ae90c8115855 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 21 Nov 2023 12:45:14 +0100 Subject: [PATCH 27/35] adapt test --- tests/testthat/test-guides.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index 9b6a200098..2a5db34803 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -51,10 +51,10 @@ test_that("Colorbar respects show.legend in layer", { df <- data_frame(x = 1:3, y = 1) p <- ggplot(df, aes(x = x, y = y, color = x)) + geom_point(size = 20, shape = 21, show.legend = FALSE) - expect_false(any(grepl("guide-box", ggplotGrob(p)$layout$name))) + expect_length(ggplot_build(p)$plot$guides$guides, 0L) p <- ggplot(df, aes(x = x, y = y, color = x)) + geom_point(size = 20, shape = 21, show.legend = TRUE) - expect_true(any(grepl("guide-box", ggplotGrob(p)$layout$name))) + expect_length(ggplot_build(p)$plot$guides$guides, 1L) }) test_that("show.legend handles named vectors", { From aba04bacd0a56b66451145dcf97914fc46688951 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 21 Nov 2023 15:05:45 +0100 Subject: [PATCH 28/35] Don't calculate key sizes twice --- R/guides-.R | 3 --- 1 file changed, 3 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index 6c2e48e9c5..a1a8684220 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -507,9 +507,6 @@ Guides <- ggproto( ) positions <- factor(positions, levels = c(.trbl, "inside")) - theme$legend.key.width <- theme$legend.key.width %||% theme$legend.key.size - theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size - directions <- rep("vertical", length(positions)) directions[positions %in% c("top", "bottom")] <- "horizontal" From ef9ad9f40cc115e211f3d179952e6492ab24864e Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 21 Nov 2023 15:06:08 +0100 Subject: [PATCH 29/35] Use `calc_element()` --- R/guides-.R | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index a1a8684220..27f55329c4 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -481,15 +481,16 @@ Guides <- ggproto( return(zeroGrob()) } - theme$legend.key.width <- theme$legend.key.width %||% theme$legend.key.size - theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size + # Populate key sizes + theme$legend.key.width <- calc_element("legend.key.width", theme) + theme$legend.key.height <- calc_element("legend.key.height", theme) grobs <- self$draw(theme, default_position) # Set spacing theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") - theme$legend.spacing.y <- theme$legend.spacing.y %||% theme$legend.spacing - theme$legend.spacing.x <- theme$legend.spacing.x %||% theme$legend.spacing + theme$legend.spacing.y <- calc_element("legend.spacing.y", theme) + theme$legend.spacing.x <- calc_element("legend.spacing.x", theme) Map( grobs = grobs, From bd56edde386896f3c9d8152b509b83d4ac2fe3fa Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 21 Nov 2023 15:11:01 +0100 Subject: [PATCH 30/35] Use conventional indexing --- R/plot-build.R | 14 +++++++------- R/theme.R | 2 +- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index 2232f89ea1..5db84e6d64 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -434,7 +434,7 @@ table_add_legends <- function(table, legends, theme) { } legends[.trbl] <- lapply(.trbl, function(position) { - box <- .subset2(legends, position) + box <- legends[[position]] if (is.zero(box)) { return(box) } @@ -449,8 +449,8 @@ table_add_legends <- function(table, legends, theme) { vp <- viewport( x = xjust, y = yjust, just = just, - height = .subset2(heights, position), - width = .subset2(widths, position) + height = heights[[position]], + width = widths[[position]] ) box <- editGrob(box, vp = vp) gtable_add_padding(box, margin) @@ -520,10 +520,10 @@ table_add_legends <- function(table, legends, theme) { plot_extent <- function(table) { layout <- table$layout data_frame0( - t = min(.subset2(layout, "t")), - r = max(.subset2(layout, "r")), - b = max(.subset2(layout, "b")), - l = min(.subset2(layout, "l")), + t = min(layout[["t"]]), + r = max(layout[["r"]]), + b = max(layout[["b"]]), + l = min(layout[["l"]]), .size = 1L ) } diff --git a/R/theme.R b/R/theme.R index 2baec7eb95..c8262cadf3 100644 --- a/R/theme.R +++ b/R/theme.R @@ -469,7 +469,7 @@ theme <- function(line, } elements$legend.text.align <- NULL } - if (is.numeric(.subset2(elements, "legend.position"))) { + if (is.numeric(elements$legend.position)) { deprecate_soft0( "3.5.0", I("A numeric `legend.position` argument in `theme()`"), "theme(legend.position.inside)" From 8a9fef54194ab9d55ebe394619d67f8c422d4c15 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 21 Nov 2023 16:13:07 +0100 Subject: [PATCH 31/35] prevent partial matching --- R/theme.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/theme.R b/R/theme.R index c8262cadf3..676e825c76 100644 --- a/R/theme.R +++ b/R/theme.R @@ -469,7 +469,7 @@ theme <- function(line, } elements$legend.text.align <- NULL } - if (is.numeric(elements$legend.position)) { + if (is.numeric(elements[["legend.position"]])) { deprecate_soft0( "3.5.0", I("A numeric `legend.position` argument in `theme()`"), "theme(legend.position.inside)" From 4808c3c490ac820f76550d233c217d240e7938e9 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 21 Nov 2023 16:57:17 +0100 Subject: [PATCH 32/35] Move justification responsiblity to `Guides$package_box()` --- R/guides-.R | 93 ++++++++++++++++++++++++++++++++++++++------------ R/plot-build.R | 40 ---------------------- 2 files changed, 71 insertions(+), 62 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index 27f55329c4..641ccd0987 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -504,7 +504,9 @@ Guides <- ggproto( draw = function(self, theme, default_position = "right", params = self$params, guides = self$guides) { positions <- vapply( - params, function(p) p$position[1] %||% default_position, character(1) + params, + function(p) p$position[1] %||% default_position, + character(1) ) positions <- factor(positions, levels = c(.trbl, "inside")) @@ -527,12 +529,14 @@ Guides <- ggproto( return(zeroGrob()) } + # Determine default direction direction <- switch( position, inside = , left = , right = "vertical", top = , bottom = "horizontal" ) + # Populate missing theme arguments theme$legend.box <- theme$legend.box %||% direction theme$legend.direction <- theme$legend.direction %||% direction theme$legend.box.just <- theme$legend.box.just %||% switch( @@ -547,54 +551,95 @@ Guides <- ggproto( heights <- lapply(grobs, function(g) sum(g$heights)) heights <- inject(unit.c(!!!heights)) + # Global justification of the complete legend box + global_just <- paste0("legend.justification.", position) + global_just <- valid.just(calc_element(global_just, theme)) + + if (position == "inside") { + # The position of inside legends are set by their justification + inside_position <- theme$legend.position.inside %||% global_just + global_xjust <- inside_position[1] + global_yjust <- inside_position[2] + global_margin <- margin() + } else { + global_xjust <- global_just[1] + global_yjust <- global_just[2] + # Legends to the side of the plot need a margin for justification + # relative to the plot panel + global_margin <- margin( + t = 1 - global_yjust, b = global_yjust, + r = 1 - global_xjust, l = global_xjust, + unit = "null" + ) + } + # 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] + box_just <- valid.just(theme$legend.box.just) + box_xjust <- box_just[1] + box_yjust <- box_just[2] # setting that is different for vertical and horizontal guide-boxes. if (identical(theme$legend.box, "horizontal")) { - # Set justification for each legend + # Set justification for each legend within the box for (i in seq_along(grobs)) { grobs[[i]] <- editGrob( grobs[[i]], - vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust), + vp = viewport(x = box_xjust, y = box_yjust, just = box_just, height = heightDetails(grobs[[i]])) ) } + spacing <- theme$legend.spacing.x - guides <- gtable_row(name = "guides", - grobs = grobs, - widths = widths, height = max(heights)) + # Set global justification + vp <- viewport( + x = global_xjust, y = global_yjust, just = global_just, + height = max(heights), + width = sum(widths, spacing * (length(grobs) - 1L)) + ) - # add space between the guide-boxes - guides <- gtable_add_col_space(guides, theme$legend.spacing.x) + # Initialise gtable as legends in a row + guides <- gtable_row( + name = "guides", grobs = grobs, + widths = widths, height = max(heights), + vp = vp + ) + + # Add space between the guide-boxes + guides <- gtable_add_col_space(guides, spacing) } else { # theme$legend.box == "vertical" - # Set justification for each legend + # Set justification for each legend within the box for (i in seq_along(grobs)) { grobs[[i]] <- editGrob( grobs[[i]], - vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust), + vp = viewport(x = box_xjust, y = box_yjust, just = box_just, width = widthDetails(grobs[[i]])) ) } + spacing <- theme$legend.spacing.y + + # Set global justification + vp <- viewport( + x = global_xjust, y = global_yjust, just = global_just, + height = sum(heights, spacing * (length(grobs) - 1L)), + width = max(widths) + ) - guides <- gtable_col(name = "guides", - grobs = grobs, - width = max(widths), heights = heights) + # Initialise gtable as legends in a column + guides <- gtable_col( + name = "guides", grobs = grobs, + width = max(widths), heights = heights, + vp = vp + ) - # add space between the guide-boxes - guides <- gtable_add_row_space(guides, theme$legend.spacing.y) + # Add space between the guide-boxes + 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) - guides <- gtable_add_rows(guides, margin[3], pos = nrow(guides)) + guides <- gtable_add_padding(guides, margin) # Add legend box background background <- element_grob(theme$legend.box.background %||% element_blank()) @@ -605,6 +650,10 @@ Guides <- ggproto( z = -Inf, clip = "off", name = "legend.box.background" ) + + # Set global margin + guides <- gtable_add_padding(guides, global_margin) + guides$name <- "guide-box" guides }, diff --git a/R/plot-build.R b/R/plot-build.R index 5db84e6d64..b91d6f6ca5 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -416,46 +416,6 @@ table_add_legends <- function(table, legends, theme) { heights[!empty] <- lapply(legends[!empty], gtable_height) spacing <- theme$legend.box.spacing %||% unit(0.2, "cm") - if (!is.zero(legends$inside)) { - # Set the justification of the legend box - just <- valid.just(calc_element("legend.justification.inside", theme)) - - position <- theme$legend.position.inside %||% just - legends$inside <- editGrob( - legends$inside, - vp = viewport( - x = position[1], - y = position[2], - just = just, - height = heights$inside, - width = widths$inside - ) - ) - } - - legends[.trbl] <- lapply(.trbl, function(position) { - box <- legends[[position]] - if (is.zero(box)) { - return(box) - } - just <- paste0("legend.justification.", position) - just <- valid.just(calc_element(just, theme)) - - # First value is xjust, second value is yjust - xjust <- just[1] - yjust <- just[2] - - margin <- margin(1 - yjust, 1 - xjust, yjust, xjust, unit = "null") - - vp <- viewport( - x = xjust, y = yjust, just = just, - height = heights[[position]], - width = widths[[position]] - ) - box <- editGrob(box, vp = vp) - gtable_add_padding(box, margin) - }) - # If legend is missing, set spacing to zero for that legend zero <- unit(0, "pt") spacing <- lapply(empty, function(is_empty) if (is_empty) zero else spacing) From 3c721b1a6d3513f80e4d8c4687bcafa7da1af769 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sat, 25 Nov 2023 14:32:21 +0100 Subject: [PATCH 33/35] Fix bug --- R/plot-build.R | 10 ++++++---- tests/testthat/test-facet-strips.R | 10 +++++----- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index b91d6f6ca5..b5ea99ebaf 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -402,15 +402,17 @@ table_add_tag <- function(table, label, theme) { # Add the legends to the gtable table_add_legends <- function(table, legends, theme) { + if (is.zero(legends)) { + legends <- rep(list(zeroGrob()), 5) + names(legends) <- c(.trbl, "inside") + } + # Extract sizes widths <- heights <- set_names( rep(list(unit(0, "cm")), length(legends)), names(legends) ) - if (is.zero(legends)) { - legends <- rep(list(zeroGrob()), 5) - names(legends) <- c(.trbl, "inside") - } + empty <- vapply(legends, is.zero, logical(1)) widths[!empty] <- lapply(legends[!empty], gtable_width) heights[!empty] <- lapply(legends[!empty], gtable_height) diff --git a/tests/testthat/test-facet-strips.R b/tests/testthat/test-facet-strips.R index b5a2a154ae..1ee8792e99 100644 --- a/tests/testthat/test-facet-strips.R +++ b/tests/testthat/test-facet-strips.R @@ -154,19 +154,19 @@ test_that("padding is only added if axis is present", { strip.switch.pad.grid = unit(10, "mm") ) pg <- ggplotGrob(p) - expect_equal(length(pg$heights), 15) + expect_equal(length(pg$heights), 17) pg <- ggplotGrob(p + scale_x_continuous(position = "top")) - expect_equal(length(pg$heights), 16) - expect_equal(as.character(pg$heights[8]), "1cm") + expect_equal(length(pg$heights), 18) + expect_equal(as.character(pg$heights[9]), "1cm") # Also add padding with negative ticks and no text (#5251) pg <- ggplotGrob( p + scale_x_continuous(labels = NULL, position = "top") + theme(axis.ticks.length.x.top = unit(-2, "mm")) ) - expect_equal(length(pg$heights), 16) - expect_equal(as.character(pg$heights[8]), "1cm") + expect_equal(length(pg$heights), 18) + expect_equal(as.character(pg$heights[9]), "1cm") }) test_that("y strip labels are rotated when strips are switched", { From 9feb77d4553d4c6d94019fcb1169bc90a83f403f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 8 Dec 2023 11:10:17 +0100 Subject: [PATCH 34/35] incorporate guide_custom --- R/guide-custom.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/guide-custom.R b/R/guide-custom.R index 3ea4fc3ffe..bca9e0214d 100644 --- a/R/guide-custom.R +++ b/R/guide-custom.R @@ -43,7 +43,7 @@ guide_custom <- function( grob, width = grobWidth(grob), height = grobHeight(grob), title = NULL, title.position = "top", margin = NULL, - position = waiver(), order = 0 + position = NULL, order = 0 ) { check_object(grob, is.grob, "a {.cls grob} object") check_object(width, is.unit, "a {.cls unit} object") From 8e52c4d0b3a583b0223222d5bc63c13498287b1b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 8 Dec 2023 11:10:17 +0100 Subject: [PATCH 35/35] incorporate guide_custom --- R/guide-custom.R | 2 +- man/guide_custom.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/guide-custom.R b/R/guide-custom.R index 3ea4fc3ffe..bca9e0214d 100644 --- a/R/guide-custom.R +++ b/R/guide-custom.R @@ -43,7 +43,7 @@ guide_custom <- function( grob, width = grobWidth(grob), height = grobHeight(grob), title = NULL, title.position = "top", margin = NULL, - position = waiver(), order = 0 + position = NULL, order = 0 ) { check_object(grob, is.grob, "a {.cls grob} object") check_object(width, is.unit, "a {.cls unit} object") diff --git a/man/guide_custom.Rd b/man/guide_custom.Rd index 3893dbc2c9..ad8a77b80b 100644 --- a/man/guide_custom.Rd +++ b/man/guide_custom.Rd @@ -11,7 +11,7 @@ guide_custom( title = NULL, title.position = "top", margin = NULL, - position = waiver(), + position = NULL, order = 0 ) }