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

Author: teunbrand

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,

man/theme.Rd

@@ -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".
+