From f89212de3784f1f8afabbf5fdaffdf4a0dc80eaa Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 2 May 2023 21:31:53 +0200 Subject: [PATCH] Tags at panels (#5167) * Fix calc_element for character/numeric input * Add function for adding tag to table * Decommission previous tag logic * Update test * Strictness about manual placement * Adjust argument description * Roxygenate * Add NEWS bullet * Add test * Simplify padding * Revert "Fix calc_element for character/numeric input" This reverts commit 5dd6c2a1ee5edc324c73980fb0995f6cb551a0c3. * Make placement choices more consistent * Tinker tests * Fix typos * Add `plot.tag.location` theme element * Use `plot.tag.location` in tag construction * Cover all combinations in tests * Update bullet --- NEWS.md | 5 +- R/plot-build.R | 189 +++++++++++------- R/theme-elements.R | 1 + R/theme.R | 12 +- man/theme.Rd | 13 +- tests/testthat/_snaps/labels.md | 8 + .../{other-position.svg => tag-in-margin.svg} | 2 +- .../labels/tag-in-panel-as-character.svg | 79 ++++++++ .../_snaps/labels/tag-in-panel-as-numeric.svg | 79 ++++++++ .../labels/tag-in-plot-as-character.svg | 79 ++++++++ ...{manual.svg => tag-in-plot-as-numeric.svg} | 2 +- tests/testthat/_snaps/theme.md | 3 +- tests/testthat/test-labels.R | 43 +++- tests/testthat/test-theme.R | 3 +- 14 files changed, 431 insertions(+), 87 deletions(-) create mode 100644 tests/testthat/_snaps/labels.md rename tests/testthat/_snaps/labels/{other-position.svg => tag-in-margin.svg} (98%) create mode 100644 tests/testthat/_snaps/labels/tag-in-panel-as-character.svg create mode 100644 tests/testthat/_snaps/labels/tag-in-panel-as-numeric.svg create mode 100644 tests/testthat/_snaps/labels/tag-in-plot-as-character.svg rename tests/testthat/_snaps/labels/{manual.svg => tag-in-plot-as-numeric.svg} (98%) diff --git a/NEWS.md b/NEWS.md index 401083cb6d..3ac733842e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # ggplot2 (development version) +* New `plot.tag.location` in `theme()` can control placement of the plot tag + in the `"margin"`, `"plot"` or the new `"panel"` option (#4297). + * `geom_text()` and `geom_label()` gained a `size.unit` parameter that set the text size to millimetres, points, centimetres, inches or picas (@teunbrand, #3799). @@ -98,7 +101,7 @@ changes and a few bug fixes as well. * Fixed bug in `coord_sf()` where graticule lines didn't obey `panel.grid.major`'s linewidth setting (@teunbrand, #5179). - + * `geom_text()` drops observations where `angle = NA` instead of throwing an error (@teunbrand, #2757). diff --git a/R/plot-build.R b/R/plot-build.R index 08f3d385fe..1bf0019324 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -268,11 +268,6 @@ ggplot_gtable.ggplot_built <- function(data) { subtitle <- element_render(theme, "plot.subtitle", plot$labels$subtitle, margin_y = TRUE) subtitle_height <- grobHeight(subtitle) - # Tag - tag <- element_render(theme, "plot.tag", plot$labels$tag, margin_y = TRUE, margin_x = TRUE) - tag_height <- grobHeight(tag) - tag_width <- grobWidth(tag) - # whole plot annotation caption <- element_render(theme, "plot.caption", plot$labels$caption, margin_y = TRUE) caption_height <- grobHeight(caption) @@ -318,75 +313,7 @@ ggplot_gtable.ggplot_built <- function(data) { plot_table <- gtable_add_grob(plot_table, caption, name = "caption", t = -1, b = -1, l = caption_l, r = caption_r, clip = "off") - plot_table <- gtable_add_rows(plot_table, unit(0, 'pt'), pos = 0) - plot_table <- gtable_add_cols(plot_table, unit(0, 'pt'), pos = 0) - plot_table <- gtable_add_rows(plot_table, unit(0, 'pt'), pos = -1) - plot_table <- gtable_add_cols(plot_table, unit(0, 'pt'), pos = -1) - - tag_pos <- theme$plot.tag.position %||% "topleft" - if (length(tag_pos) == 2) tag_pos <- "manual" - valid_pos <- c("topleft", "top", "topright", "left", "right", "bottomleft", - "bottom", "bottomright") - - if (!(tag_pos == "manual" || tag_pos %in% valid_pos)) { - cli::cli_abort("{.arg plot.tag.position} should be a coordinate or one of {.or {.val {valid_pos}}}") - } - - if (tag_pos == "manual") { - xpos <- theme$plot.tag.position[1] - ypos <- theme$plot.tag.position[2] - tag_parent <- justify_grobs(tag, x = xpos, y = ypos, - hjust = theme$plot.tag$hjust, - vjust = theme$plot.tag$vjust, - int_angle = theme$plot.tag$angle, - debug = theme$plot.tag$debug) - plot_table <- gtable_add_grob(plot_table, tag_parent, name = "tag", t = 1, - b = nrow(plot_table), l = 1, - r = ncol(plot_table), clip = "off") - } else { - # Widths and heights are reassembled below instead of assigning into them - # in order to avoid bug in grid 3.2 and below. - if (tag_pos == "topleft") { - plot_table$widths <- unit.c(tag_width, plot_table$widths[-1]) - plot_table$heights <- unit.c(tag_height, plot_table$heights[-1]) - plot_table <- gtable_add_grob(plot_table, tag, name = "tag", - t = 1, l = 1, clip = "off") - } else if (tag_pos == "top") { - plot_table$heights <- unit.c(tag_height, plot_table$heights[-1]) - plot_table <- gtable_add_grob(plot_table, tag, name = "tag", - t = 1, l = 1, r = ncol(plot_table), - clip = "off") - } else if (tag_pos == "topright") { - plot_table$widths <- unit.c(plot_table$widths[-ncol(plot_table)], tag_width) - plot_table$heights <- unit.c(tag_height, plot_table$heights[-1]) - plot_table <- gtable_add_grob(plot_table, tag, name = "tag", - t = 1, l = ncol(plot_table), clip = "off") - } else if (tag_pos == "left") { - plot_table$widths <- unit.c(tag_width, plot_table$widths[-1]) - plot_table <- gtable_add_grob(plot_table, tag, name = "tag", - t = 1, b = nrow(plot_table), l = 1, - clip = "off") - } else if (tag_pos == "right") { - plot_table$widths <- unit.c(plot_table$widths[-ncol(plot_table)], tag_width) - plot_table <- gtable_add_grob(plot_table, tag, name = "tag", - t = 1, b = nrow(plot_table), l = ncol(plot_table), - clip = "off") - } else if (tag_pos == "bottomleft") { - plot_table$widths <- unit.c(tag_width, plot_table$widths[-1]) - plot_table$heights <- unit.c(plot_table$heights[-nrow(plot_table)], tag_height) - plot_table <- gtable_add_grob(plot_table, tag, name = "tag", - t = nrow(plot_table), l = 1, clip = "off") - } else if (tag_pos == "bottom") { - plot_table$heights <- unit.c(plot_table$heights[-nrow(plot_table)], tag_height) - plot_table <- gtable_add_grob(plot_table, tag, name = "tag", - t = nrow(plot_table), l = 1, r = ncol(plot_table), clip = "off") - } else if (tag_pos == "bottomright") { - plot_table$widths <- unit.c(plot_table$widths[-ncol(plot_table)], tag_width) - plot_table$heights <- unit.c(plot_table$heights[-nrow(plot_table)], tag_height) - plot_table <- gtable_add_grob(plot_table, tag, name = "tag", - t = nrow(plot_table), l = ncol(plot_table), clip = "off") - } - } + plot_table <- table_add_tag(plot_table, plot$labels$tag, theme) # Margins plot_table <- gtable_add_rows(plot_table, theme$plot.margin[1], pos = 0) @@ -431,3 +358,117 @@ by_layer <- function(f, layers, data, step = NULL) { ) out } + +# Add the tag element to the gtable +table_add_tag <- function(table, label, theme) { + # Initialise the tag margins + table <- gtable_add_padding(table, unit(0, "pt")) + + # Early exit when label is absent or element is blank + if (length(label) < 1) { + return(table) + } + element <- calc_element("plot.tag", theme) + if (inherits(element, "element_blank")) { + return(table) + } + + # Resolve position + position <- calc_element("plot.tag.position", theme) %||% "topleft" + location <- calc_element("plot.tag.location", theme) %||% + (if (is.numeric(position)) "plot" else "margin") + + if (is.numeric(position)) { + if (location == "margin") { + cli::cli_abort(paste0( + "A {.cls numeric} {.arg plot.tag.position} cannot be used with ", + "{.code \"margin\"} as {.arg plot.tag.location}." + )) + } + if (length(position) != 2) { + cli::cli_abort(paste0( + "A {.cls numeric} {.arg plot.tag.position} ", + "theme setting must have length 2." + )) + } + top <- left <- right <- bottom <- FALSE + } else { + # Break position into top/left/right/bottom + position <- arg_match0( + position[1], + c("topleft", "top", "topright", "left", + "right", "bottomleft", "bottom", "bottomright"), + arg_nm = "plot.tag.position" + ) + top <- position %in% c("topleft", "top", "topright") + left <- position %in% c("topleft", "left", "bottomleft") + right <- position %in% c("topright", "right", "bottomright") + bottom <- position %in% c("bottomleft", "bottom", "bottomright") + } + + # Resolve tag and sizes + tag <- element_grob(element, label = label, margin_y = TRUE, margin_x = TRUE) + height <- grobHeight(tag) + width <- grobWidth(tag) + + if (location %in% c("plot", "panel")) { + if (!is.numeric(position)) { + if (right || left) { + x <- (1 - element$hjust) * width + if (right) { + x <- unit(1, "npc") - x + } + } else { + x <- unit(element$hjust, "npc") + } + if (top || bottom) { + y <- (1 - element$vjust) * height + if (top) { + y <- unit(1, "npc") - y + } + } else { + y <- unit(element$vjust, "npc") + } + } else { + x <- unit(position[1], "npc") + y <- unit(position[2], "npc") + } + # Do manual placement of tag + tag <- justify_grobs( + tag, x = x, y = y, + hjust = element$hjust, vjust = element$vjust, + int_angle = element$angle, debug = element$debug + ) + if (location == "plot") { + table <- gtable_add_grob( + table, tag, name = "tag", clip = "off", + t = 1, b = nrow(table), l = 1, r = ncol(table) + ) + return(table) + } + } + + if (location == "panel") { + place <- find_panel(table) + } else { + n_col <- ncol(table) + n_row <- nrow(table) + # Actually fill margin with relevant units + if (top) table$heights <- unit.c(height, table$heights[-1]) + if (left) table$widths <- unit.c(width, table$widths[-1]) + if (right) table$widths <- unit.c(table$widths[-n_col], width) + if (bottom) table$heights <- unit.c(table$heights[-n_row], height) + place <- data_frame0(t = 1L, r = n_col, b = n_row, l = 1L) + } + + # Shrink placement to position + if (top) place$b <- place$t + if (left) place$r <- place$l + if (right) place$l <- place$r + if (bottom) place$t <- place$b + + gtable_add_grob( + table, tag, name = "tag", clip = "off", + t = place$t, l = place$l, b = place$b, r = place$r + ) +} diff --git a/R/theme-elements.R b/R/theme-elements.R index e4322b289a..ab8624a761 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -523,6 +523,7 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { plot.caption.position = el_def("character"), plot.tag = el_def("element_text", "title"), plot.tag.position = el_def(c("character", "numeric")), # Need to also accept numbers + plot.tag.location = el_def("character"), plot.margin = el_def("margin"), aspect.ratio = el_def("numeric") diff --git a/R/theme.R b/R/theme.R index 29f6e318bf..086c35174e 100644 --- a/R/theme.R +++ b/R/theme.R @@ -133,10 +133,15 @@ #' for margins and plot tag). #' @param plot.tag upper-left label to identify a plot (text appearance) #' ([element_text()]; inherits from `title`) left-aligned by default +#' @param plot.tag.location The placement of the tag as a string, one of +#' `"panel"`, `"plot"` or `"margin"`. Respectively, these will place the tag +#' inside the panel space, anywhere in the plot as a whole, or in the margin +#' around the panel space. #' @param plot.tag.position The position of the tag as a string ("topleft", -#' "top", "topright", "left", "right", "bottomleft", "bottom", "bottomright) -#' or a coordinate. If a string, extra space will be added to accommodate the -#' tag. +#' "top", "topright", "left", "right", "bottomleft", "bottom", "bottomright") +#' or a coordinate. If a coordinate, can be a numeric vector of length 2 to +#' set the x,y-coordinate relative to the whole plot. The coordinate option +#' is unavailable for `plot.tag.location = "margin"`. #' @param plot.margin margin around entire plot (`unit` with the sizes of #' the top, right, bottom, and left margins) #' @@ -357,6 +362,7 @@ theme <- function(line, plot.caption.position, plot.tag, plot.tag.position, + plot.tag.location, plot.margin, strip.background, strip.background.x, diff --git a/man/theme.Rd b/man/theme.Rd index 4e1fd02181..29cfe9f9b3 100644 --- a/man/theme.Rd +++ b/man/theme.Rd @@ -87,6 +87,7 @@ theme( plot.caption.position, plot.tag, plot.tag.position, + plot.tag.location, plot.margin, strip.background, strip.background.x, @@ -248,9 +249,15 @@ inherits from \code{title}) left-aligned by default} (\code{\link[=element_text]{element_text()}}; inherits from \code{title}) left-aligned by default} \item{plot.tag.position}{The position of the tag as a string ("topleft", -"top", "topright", "left", "right", "bottomleft", "bottom", "bottomright) -or a coordinate. If a string, extra space will be added to accommodate the -tag.} +"top", "topright", "left", "right", "bottomleft", "bottom", "bottomright") +or a coordinate. If a coordinate, can be a numeric vector of length 2 to +set the x,y-coordinate relative to the whole plot. The coordinate option +is unavailable for \code{plot.tag.location = "margin"}.} + +\item{plot.tag.location}{The placement of the tag as a string, one of +\code{"panel"}, \code{"plot"} or \code{"margin"}. Respectively, these will place the tag +inside the panel space, anywhere in the plot as a whole, or in the margin +around the panel space.} \item{plot.margin}{margin around entire plot (\code{unit} with the sizes of the top, right, bottom, and left margins)} diff --git a/tests/testthat/_snaps/labels.md b/tests/testthat/_snaps/labels.md new file mode 100644 index 0000000000..350e19315f --- /dev/null +++ b/tests/testthat/_snaps/labels.md @@ -0,0 +1,8 @@ +# plot.tag.position rejects invalid input + + The `plot.tag.position` theme element must be a object. + +--- + + `plot.tag.position` must be one of "topleft", "top", "topright", "left", "right", "bottomleft", "bottom", or "bottomright", not "foobar". + diff --git a/tests/testthat/_snaps/labels/other-position.svg b/tests/testthat/_snaps/labels/tag-in-margin.svg similarity index 98% rename from tests/testthat/_snaps/labels/other-position.svg rename to tests/testthat/_snaps/labels/tag-in-margin.svg index f89c5248c3..9a60fe22f9 100644 --- a/tests/testthat/_snaps/labels/other-position.svg +++ b/tests/testthat/_snaps/labels/tag-in-margin.svg @@ -73,7 +73,7 @@ 10.0 x y -Other position +Tag in margin Fig. A) diff --git a/tests/testthat/_snaps/labels/tag-in-panel-as-character.svg b/tests/testthat/_snaps/labels/tag-in-panel-as-character.svg new file mode 100644 index 0000000000..3f6d287ae2 --- /dev/null +++ b/tests/testthat/_snaps/labels/tag-in-panel-as-character.svg @@ -0,0 +1,79 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2.5 +5.0 +7.5 +10.0 + + + + + + + + +2.5 +5.0 +7.5 +10.0 +x +y +Tag in panel, as character +Fig. A) + + diff --git a/tests/testthat/_snaps/labels/tag-in-panel-as-numeric.svg b/tests/testthat/_snaps/labels/tag-in-panel-as-numeric.svg new file mode 100644 index 0000000000..9798dd575e --- /dev/null +++ b/tests/testthat/_snaps/labels/tag-in-panel-as-numeric.svg @@ -0,0 +1,79 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2.5 +5.0 +7.5 +10.0 + + + + + + + + +2.5 +5.0 +7.5 +10.0 +x +y +Tag in panel, as numeric +Fig. A) + + diff --git a/tests/testthat/_snaps/labels/tag-in-plot-as-character.svg b/tests/testthat/_snaps/labels/tag-in-plot-as-character.svg new file mode 100644 index 0000000000..aca8c3e6ca --- /dev/null +++ b/tests/testthat/_snaps/labels/tag-in-plot-as-character.svg @@ -0,0 +1,79 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2.5 +5.0 +7.5 +10.0 + + + + + + + + +2.5 +5.0 +7.5 +10.0 +x +y +Tag in plot, as character +Fig. A) + + diff --git a/tests/testthat/_snaps/labels/manual.svg b/tests/testthat/_snaps/labels/tag-in-plot-as-numeric.svg similarity index 98% rename from tests/testthat/_snaps/labels/manual.svg rename to tests/testthat/_snaps/labels/tag-in-plot-as-numeric.svg index e908279714..7d6ceebd40 100644 --- a/tests/testthat/_snaps/labels/manual.svg +++ b/tests/testthat/_snaps/labels/tag-in-plot-as-numeric.svg @@ -73,7 +73,7 @@ 10.0 x y -Manual +Tag in plot, as numeric Fig. A) diff --git a/tests/testthat/_snaps/theme.md b/tests/testthat/_snaps/theme.md index 0fe584926a..b879a97d01 100644 --- a/tests/testthat/_snaps/theme.md +++ b/tests/testthat/_snaps/theme.md @@ -50,5 +50,6 @@ --- - `plot.tag.position` should be a coordinate or one of "topleft", "top", "topright", "left", "right", "bottomleft", "bottom", or "bottomright" + `plot.tag.position` must be one of "topleft", "top", "topright", "left", "right", "bottomleft", "bottom", or "bottomright", not "test". + i Did you mean "left"? diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index 2517b8fac2..78a77db663 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -69,6 +69,27 @@ test_that("alt text is returned", { expect_equal(get_alt_text(p), "An alt text") }) + +test_that("plot.tag.position rejects invalid input", { + p <- ggplot(mtcars, aes(mpg, disp)) + geom_point() + labs(tag = "Fig. A)") + + expect_snapshot_error( + ggplotGrob(p + theme(plot.tag.position = TRUE)) + ) + expect_snapshot_error( + ggplotGrob(p + theme(plot.tag.position = "foobar")) + ) + expect_error( + ggplotGrob(p + theme(plot.tag.position = c(0, 0.5, 1))), + "must have length 2" + ) + expect_error( + ggplotGrob(p + theme(plot.tag.position = c(0, 0), plot.tag.location = "margin")), + "cannot be used with `\"margin\"" + ) + +}) + test_that("position axis label hierarchy works as intended", { df <- data_frame(foo = c(1e1, 1e5), bar = c(0, 100)) @@ -210,6 +231,24 @@ test_that("tags are drawn correctly", { p <- ggplot(dat, aes(x = x, y = y)) + geom_point() + labs(tag = "Fig. A)") expect_doppelganger("defaults", p) - expect_doppelganger("Other position", p + theme(plot.tag.position = 'bottom')) - expect_doppelganger("Manual", p + theme(plot.tag.position = c(0.05, 0.05))) + expect_doppelganger( + "Tag in margin", + p + theme(plot.tag.position = "bottom", plot.tag.location = "margin") + ) + expect_doppelganger( + "Tag in panel, as character", + p + theme(plot.tag.position = "topright", plot.tag.location = "panel") + ) + expect_doppelganger( + "Tag in panel, as numeric", + p + theme(plot.tag.position = c(0.25, 0.25), plot.tag.location = "panel") + ) + expect_doppelganger( + "Tag in plot, as character", + p + theme(plot.tag.position = "bottomleft", plot.tag.location = "plot") + ) + expect_doppelganger( + "Tag in plot, as numeric", + p + theme(plot.tag.position = c(0.05, 0.05), plot.tag.location = "plot") + ) }) diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index 19d063bb3e..9973f1128d 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -487,7 +487,8 @@ test_that("Theme elements are checked during build", { p <- ggplot(mtcars) + geom_point(aes(disp, mpg)) + theme(plot.caption.position = "test") expect_snapshot_error(ggplotGrob(p)) - p <- ggplot(mtcars) + geom_point(aes(disp, mpg)) + theme(plot.tag.position = "test") + p <- ggplot(mtcars) + geom_point(aes(disp, mpg)) + + theme(plot.tag.position = "test") + labs(tag = "test") expect_snapshot_error(ggplotGrob(p)) })