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 5dd6c2a.

* 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

@@ -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).
 

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
+ )
+}

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")

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,

tests/testthat/_snaps/labels.md

@@ -0,0 +1,8 @@
+# plot.tag.position rejects invalid input
+
+ The `plot.tag.position` theme element must be a <character/numeric> object.
+
+---
+
+ `plot.tag.position` must be one of "topleft", "top", "topright", "left", "right", "bottomleft", "bottom", or "bottomright", not "foobar".
+