Refactor titleGrob() (#5273)

* reimplement titleGrob

* strips don't adjust titleGrob's viewports

* Further simplification

* accept rounding errors in visual tests

* Simplify `assemble_strips()`

* Add back debug rectangles

* Add (back) comments

* Retire functions that are no longer needed

* Add code review suggestions

* Leave news bullet for extension maintainers

Author: teunbrand

NEWS.md

@@ -1,5 +1,6 @@
 # ggplot2 (development version)
 
+* As an internal change, the `titleGrob()` has been refactored to be faster.
 * The `translate_shape_string()` internal function is now exported for use in
   extensions of point layers (@teunbrand, #5191).
 * Fixed bug in `coord_sf()` where graticule lines didn't obey 

R/labeller.R

@@ -557,31 +557,12 @@ assemble_strips <- function(grobs, theme, horizontal = TRUE, clip) {
     return(grobs)
   }
 
-  # Add margins to non-titleGrobs so they behave eqivalently
-  grobs[] <- lapply(grobs, function(g) {
-    if (inherits(g, "titleGrob")) return(g)
-    add_margins(gList(g), grobHeight(g), grobWidth(g), margin_x = TRUE, margin_y = TRUE)
-  })
-
   if (horizontal) {
-    height <- max_height(lapply(grobs, function(x) x$heights[2]))
+    height <- max_height(grobs)
     width <- unit(1, "null")
   } else {
     height <- unit(1, "null")
-    width <- max_width(lapply(grobs, function(x) x$widths[2]))
-  }
-  grobs[] <- lapply(grobs, function(x) {
-    # Avoid unit subset assignment to support R 3.2
-    x$widths <- unit.c(x$widths[1], width, x$widths[c(-1, -2)])
-    x$heights <- unit.c(x$heights[1], height, x$heights[c(-1, -2)])
-    x$vp$parent$layout$widths <- unit.c(x$vp$parent$layout$widths[1], width, x$vp$parent$layout$widths[c(-1, -2)])
-    x$vp$parent$layout$heights <- unit.c(x$vp$parent$layout$heights[1], height, x$vp$parent$layout$heights[c(-1, -2)])
-    x
-  })
-  if (horizontal) {
-    height <- sum(grobs[[1]]$heights)
-  } else {
-    width <- sum(grobs[[1]]$widths)
+    width <- max_width(grobs)
   }
 
   background <- if (horizontal) "strip.background.x" else "strip.background.y"

R/margins.R

@@ -12,34 +12,31 @@ is.margin <- function(x) {
   inherits(x, "margin")
 }
 
-margin_height <- function(grob, margins) {
-  if (is.zero(grob)) return(unit(0, "cm"))
-
-  grobHeight(grob) + margins[1] + margins[3]
-}
-
-margin_width <- function(grob, margins) {
-  if (is.zero(grob)) return(unit(0, "cm"))
-
-  grobWidth(grob) + margins[2] + margins[4]
-}
-
-#' Text grob, height, and width
+#' Create a text grob with the proper location and margins
 #'
-#' This function returns a list containing a text grob (and, optionally,
-#' debugging grobs) and the height and width of the text grob.
+#' `titleGrob()` is called when creating titles and labels for axes, legends,
+#' and facet strips.
 #'
-#' @param label Either `NULL`, a string (length 1 character vector), or
-#'   an expression.
-#' @param x,y x and y locations where the text is to be placed. If `x` and `y`
-#'   are `NULL`, `hjust` and `vjust` are used to determine the location.
-#' @inheritParams titleGrob
+#' @param label Text to place on the plot. These maybe axis titles, axis labels,
+#'   facet strip titles, etc.
+#' @param x,y x and y locations where the text is to be placed.
+#' @param hjust,vjust Horizontal and vertical justification of the text.
+#' @param angle Angle of rotation of the text.
+#' @param gp Additional graphical parameters in a call to `gpar()`.
+#' @param margin Margins around the text. See [margin()] for more
+#'   details.
+#' @param margin_x,margin_y Whether or not to add margins in the x/y direction.
+#' @param debug If `TRUE`, aids visual debugging by drawing a solid
+#'   rectangle behind the complete text area, and a point where each label
+#'   is anchored.
 #'
 #' @noRd
-title_spec <- function(label, x, y, hjust, vjust, angle, gp = gpar(),
-                       debug = FALSE, check.overlap = FALSE) {
-
-  if (is.null(label)) return(zeroGrob())
+titleGrob <- function(label, x, y, hjust, vjust, angle = 0, gp = gpar(),
+                      margin = NULL, margin_x = FALSE, margin_y = FALSE,
+                      debug = FALSE, check.overlap = FALSE) {
+  if (is.null(label)) {
+    return(zeroGrob())
+  }
 
   # We rotate the justifiation values to obtain the correct x and y reference point,
   # since hjust and vjust are applied relative to the rotated text frame in textGrob
@@ -48,16 +45,17 @@ title_spec <- function(label, x, y, hjust, vjust, angle, gp = gpar(),
   n <- max(length(x), length(y), 1)
   x <- x %||% unit(rep(just$hjust, n), "npc")
   y <- y %||% unit(rep(just$vjust, n), "npc")
+  if (!is.unit(x)) {
+    x <- unit(x, "npc")
+  }
+  if (!is.unit(y)) {
+    y <- unit(y, "npc")
+  }
 
-  text_grob <- textGrob(
-    label,
-    x,
-    y,
-    hjust = hjust,
-    vjust = vjust,
-    rot = angle,
-    gp = gp,
-    check.overlap = check.overlap
+  grob <- textGrob(
+    label, x, y,
+    hjust = hjust, vjust = vjust,
+    rot = angle, gp = gp, check.overlap = check.overlap
   )
 
   # The grob dimensions don't include the text descenders, so these need to be added
@@ -71,140 +69,78 @@ title_spec <- function(label, x, y, hjust, vjust, angle, gp = gpar(),
   # Use trigonometry to calculate grobheight and width for rotated grobs. This is only
   # exactly correct when vjust = 1. We need to take the absolute value so we don't make
   # the grob smaller when it's flipped over.
-  text_height <- unit(1, "grobheight", text_grob) + abs(cos(angle[1] / 180 * pi)) * descent
-  text_width <- unit(1, "grobwidth", text_grob) + abs(sin(angle[1] / 180 * pi)) * descent
+  rad <- (angle[1] %% 360) / 180 * pi
+  x_descent <- abs(sin(rad)) * descent
+  y_descent <- abs(cos(rad)) * descent
 
-  if (isTRUE(debug)) {
-    children <- gList(
-      rectGrob(gp = gpar(fill = "cornsilk", col = NA)),
-      pointsGrob(x, y, pch = 20, gp = gpar(col = "gold")),
-      text_grob
-    )
-  } else {
-    children <- gList(text_grob)
-  }
-
-  list(
-    text_grob = children,
-    text_height = text_height,
-    text_width = text_width
-  )
-}
-
-#' Add margins
-#'
-#' Given a text grob, `add_margins()` adds margins around the grob in the
-#' directions determined by `margin_x` and `margin_y`.
-#'
-#' @param grob A gList containing a grob, such as a text grob
-#' @param height,width Usually the height and width of the text grob. Passed as
-#'   separate arguments from the grob itself because in the special case of
-#'   facet strip labels each set of strips should share the same height and
-#'   width, even if the labels are of different length.
-#' @inheritParams titleGrob
-#'
-#' @noRd
-add_margins <- function(grob, height, width, margin = NULL,
-                        gp = gpar(), margin_x = FALSE, margin_y = FALSE) {
+  # Set text size to actual size including descenders
+  width  <- unit(1, "grobwidth",  grob) + x_descent
+  height <- unit(1, "grobheight", grob) + y_descent
 
+  # Resolve margin
   if (is.null(margin)) {
     margin <- margin(0, 0, 0, 0)
   }
+  margin_x <- isTRUE(margin_x)
+  margin_y <- isTRUE(margin_y)
+
+  # Initialise new values for position and dimensions
+  new_x <- NULL
+  new_y <- NULL
+  new_width  <- NULL
+  new_height <- NULL
+
+  # Calculate new x/width
+  if (margin_x) {
+    new_width <- unit.c(margin[4], width, margin[2])
+    new_x <- x - margin[2] * just$hjust + margin[4] * (1 - just$hjust)
+  }
 
-  if (margin_x && margin_y) {
-    widths <- unit.c(margin[4], width, margin[2])
-    heights <- unit.c(margin[1], height, margin[3])
+  # Calculate new y/height
+  if (margin_y) {
+    new_height <- unit.c(margin[1], height, margin[3])
+    new_y <- y - margin[1] * just$vjust + margin[3] * (1 - just$vjust)
+  }
 
-    vp <- viewport(
-      layout = grid.layout(3, 3, heights = heights, widths = widths),
-      gp = gp
-    )
-    child_vp <- viewport(layout.pos.row = 2, layout.pos.col = 2)
-  } else if (margin_x) {
-    widths <- unit.c(margin[4], width, margin[2])
-    vp <- viewport(layout = grid.layout(1, 3, widths = widths), gp = gp)
-    child_vp <- viewport(layout.pos.col = 2)
+  # If only one margin is set, the other dimension is a null unit
+  if (xor(margin_x, margin_y)) {
+    new_width  <- new_width  %||% unit(1, "null")
+    new_height <- new_height %||% unit(1, "null")
+  }
 
-    heights <- unit(1, "null")
-  } else if (margin_y) {
-    heights <- unit.c(margin[1], height, margin[3])
+  # If we haven't touched the new positions/dimensions, use the previous ones
+  new_width  <- new_width  %||% width
+  new_height <- new_height %||% height
+  x <- new_x %||% x
+  y <- new_y %||% y
 
-    vp <- viewport(layout = grid.layout(3, 1, heights = heights), gp = gp)
-    child_vp <- viewport(layout.pos.row = 2)
+  # Adjust the grob
+  grob$x <- x
+  grob$y <- y
 
-    widths <- unit(1, "null")
-  } else {
-    widths <- width
-    heights <- height
-    return(
-      gTree(
-        children = grob,
-        widths = widths,
-        heights = heights,
-        cl = "titleGrob"
-      )
+  # Add debug rectangles/points if necessary
+  if (isTRUE(debug)) {
+    children <- gList(
+      rectGrob(
+        x = x, y = y, width = width, height = height,
+        hjust = just$hjust, vjust = just$vjust,
+        gp = gpar(fill = "cornsilk", col = NA)
+      ),
+      pointsGrob(x, y, pch = 20, gp = gpar(col = "gold")),
+      grob
     )
+  } else {
+    children <- gList(grob)
   }
 
   gTree(
-    children = grob,
-    vp = vpTree(vp, vpList(child_vp)),
-    widths = widths,
-    heights = heights,
+    children = children,
+    widths   = new_width,
+    heights  = new_height,
     cl = "titleGrob"
   )
 }
 
-#' Create a text grob with the proper location and margins
-#'
-#' `titleGrob()` is called when creating titles and labels for axes, legends,
-#' and facet strips.
-#'
-#' @param label Text to place on the plot. These maybe axis titles, axis labels,
-#'   facet strip titles, etc.
-#' @param x,y x and y locations where the text is to be placed.
-#' @param hjust,vjust Horizontal and vertical justification of the text.
-#' @param angle Angle of rotation of the text.
-#' @param gp Additional graphical parameters in a call to `gpar()`.
-#' @param margin Margins around the text. See [margin()] for more
-#'   details.
-#' @param margin_x,margin_y Whether or not to add margins in the x/y direction.
-#' @param debug If `TRUE`, aids visual debugging by drawing a solid
-#'   rectangle behind the complete text area, and a point where each label
-#'   is anchored.
-#'
-#' @noRd
-titleGrob <- function(label, x, y, hjust, vjust, angle = 0, gp = gpar(),
-                      margin = NULL, margin_x = FALSE, margin_y = FALSE,
-                      debug = FALSE, check.overlap = FALSE) {
-
-  if (is.null(label))
-    return(zeroGrob())
-
-  # Get text grob, text height, and text width
-  grob_details <- title_spec(
-    label,
-    x = x,
-    y = y,
-    hjust = hjust,
-    vjust = vjust,
-    angle = angle,
-    gp = gp,
-    debug = debug,
-    check.overlap = check.overlap
-  )
-
-  add_margins(
-    grob = grob_details$text_grob,
-    height = grob_details$text_height,
-    width = grob_details$text_width,
-    gp = gp,
-    margin = margin,
-    margin_x = margin_x,
-    margin_y = margin_y
-  )
-}
-
 #' @export
 widthDetails.titleGrob <- function(x) {
   sum(x$widths)