Clean up strip rendering code (#3683)

Author: thomasp85

.travis.yml

@@ -9,6 +9,7 @@ matrix:
     env: _R_CHECK_SYSTEM_CLOCK_=false
   - r: release
     env: VDIFFR_RUN_TESTS=true
+    env: VDIFFR_LOG_PATH="../vdiffr.Rout.fail"
     before_cache:
     - Rscript -e 'remotes::install_cran("pkgdown")'
     - Rscript -e 'remotes::install_github("tidyverse/tidytemplate")'

R/labeller.r

@@ -496,68 +496,35 @@ build_strip <- function(label_df, labeller, theme, horizontal) {
     })
   }
 
-  text_theme <- if (horizontal) "strip.text.x" else "strip.text.y"
-
-  element <- calc_element(text_theme, theme)
-
-  if (inherits(element, "element_blank")) {
-    grobs <- rep(list(zeroGrob()), nrow(label_df))
-    return(structure(
-      list(grobs, grobs),
-      names = if (horizontal) c('top', 'bottom') else c('left', 'right')
-    ))
-  }
-
   # Create matrix of labels
   labels <- lapply(labeller(label_df), cbind)
   labels <- do.call("cbind", labels)
 
-  gp <- gpar(
-    fontsize = element$size,
-    col = element$colour,
-    fontfamily = element$family,
-    fontface = element$face,
-    lineheight = element$lineheight
-  )
-
   if (horizontal) {
+    grobs_top <- lapply(labels, element_render, theme = theme,
+                        element = "strip.text.x.top", margin_x = TRUE,
+                        margin_y = TRUE)
+    grobs_top <- assemble_strips(grobs_top, theme, horizontal, clip = "on")
 
-    grobs <- create_strip_labels(labels, element, gp)
-    grobs <- ggstrip(grobs, theme, element, gp, horizontal, clip = "on")
+    grobs_bottom <- lapply(labels, element_render, theme = theme,
+                           element = "strip.text.x.bottom", margin_x = TRUE,
+                           margin_y = TRUE)
+    grobs_bottom <- assemble_strips(grobs_bottom, theme, horizontal, clip = "on")
 
     list(
-      top = grobs,
-      bottom = grobs
+      top = grobs_top,
+      bottom = grobs_bottom
     )
   } else {
+    grobs_left <- lapply(labels, element_render, theme = theme,
+                         element = "strip.text.y.left", margin_x = TRUE,
+                         margin_y = TRUE)
+    grobs_left <- assemble_strips(grobs_left, theme, horizontal, clip = "on")
 
-    grobs <- create_strip_labels(labels, element, gp)
-    grobs_right <- grobs[, rev(seq_len(ncol(grobs))), drop = FALSE]
-
-    grobs_right <- ggstrip(
-      grobs_right,
-      theme,
-      element,
-      gp,
-      horizontal,
-      clip = "on"
-    )
-
-    # Change angle of strip labels for y strips that are placed on the left side
-    if (inherits(element, "element_text")) {
-      element$angle <- adjust_angle(element$angle)
-    }
-
-    grobs_left <- create_strip_labels(labels, element, gp)
-
-    grobs_left <- ggstrip(
-      grobs_left,
-      theme,
-      element,
-      gp,
-      horizontal,
-      clip = "on"
-    )
+    grobs_right <- lapply(labels, element_render, theme = theme,
+                          element = "strip.text.y.right", margin_x = TRUE,
+                          margin_y = TRUE)
+    grobs_right <- assemble_strips(grobs_right, theme, horizontal, clip = "on")
 
     list(
       left = grobs_left,
@@ -566,126 +533,57 @@ build_strip <- function(label_df, labeller, theme, horizontal) {
   }
 }
 
-#' Create list of strip labels
-#'
-#' Calls [title_spec()] on all the labels for a set of strips to create a list
-#' of text grobs, heights, and widths.
-#'
-#' @param labels Matrix of strip labels
-#' @param element Theme element (see [calc_element()]).
-#' @param gp Additional graphical parameters.
-#'
-#' @noRd
-create_strip_labels <- function(labels, element, gp) {
-  grobs <- lapply(labels, title_spec,
-    x = NULL,
-    y = NULL,
-    hjust = element$hjust,
-    vjust = element$vjust,
-    angle = element$angle,
-    gp = gp,
-    debug = element$debug
-  )
-  dim(grobs) <- dim(labels)
-  grobs
-}
-
 #' Grob for strip labels
 #'
 #' Takes the output from title_spec, adds margins, creates gList with strip
 #' background and label, and returns gtable matrix.
 #'
-#' @param grobs Output from [title_spec()].
+#' @param grobs Output from [titleGrob()].
 #' @param theme Theme object.
-#' @param element Theme element (see [calc_element()]).
-#' @param gp Additional graphical parameters.
 #' @param horizontal Whether the strips are horizontal (e.g. x facets) or not.
 #' @param clip should drawing be clipped to the specified cells (‘"on"’),the
 #'   entire table (‘"inherit"’), or not at all (‘"off"’).
 #'
 #' @noRd
-ggstrip <- function(grobs, theme, element, gp, horizontal = TRUE, clip) {
+assemble_strips <- function(grobs, theme, horizontal = TRUE, clip) {
+  if (length(grobs) == 0 || is.zero(grobs[[1]])) 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$text_height))
+    height <- max_height(lapply(grobs, function(x) x$heights[2]))
     width <- unit(1, "null")
   } else {
     height <- unit(1, "null")
-    width <- max_width(lapply(grobs, function(x) x$text_width))
+    width <- max_width(lapply(grobs, function(x) x$widths[2]))
   }
-
-  # Add margins around text grob
-  grobs <- apply(
-    grobs,
-    c(1, 2),
-    function(x) {
-      add_margins(
-        grob = x[[1]]$text_grob,
-        height = height,
-        width = width,
-        gp = gp,
-        margin = element$margin,
-        margin_x = TRUE,
-        margin_y = TRUE
-      )
-    }
-  )
-
-  background <- if (horizontal) "strip.background.x" else "strip.background.y"
-
-  # Put text on a strip
-  grobs <- apply(
-    grobs,
-    c(1, 2),
-    function(label) {
-      ggname(
-        "strip",
-        gTree(
-          children = gList(
-            element_render(theme, background),
-            label[[1]]
-          )
-        )
-      )
-    })
-
+  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 <- height + sum(element$margin[c(1, 3)])
+    height <- sum(grobs[[1]]$heights)
   } else {
-    width <- width + sum(element$margin[c(2, 4)])
+    width <- sum(grobs[[1]]$widths)
   }
 
+  background <- if (horizontal) "strip.background.x" else "strip.background.y"
+  background <- element_render(theme, background)
 
-  apply(
-    grobs,
-    1,
-    function(x) {
-      if (horizontal) {
-        mat <- matrix(x, ncol = 1)
-      } else {
-        mat <- matrix(x, nrow = 1)
-      }
-
-      gtable_matrix(
-        "strip",
-        mat,
-        rep(width, ncol(mat)),
-        rep(height, nrow(mat)),
-        clip = clip
-      )
-    })
-
-}
-
-# Helper to adjust angle of switched strips
-adjust_angle <- function(angle) {
-  if (is.null(angle)) {
-    -90
-  } else if ((angle + 180) > 360) {
-    angle - 180
-  } else {
-    angle + 180
-  }
+  # Put text on a strip
+  lapply(grobs, function(x) {
+    strip <- ggname("strip", gTree(children = gList(background, x)))
+    strip_table <- gtable(width, height, name = "strip")
+    gtable_add_grob(strip_table, strip, 1, 1, clip = clip)
+  })
 }
 
 # Check for old school labeller

R/margins.R

@@ -96,7 +96,7 @@ title_spec <- function(label, x, y, hjust, vjust, angle, gp = gpar(),
 #' Given a text grob, `add_margins()` adds margins around the grob in the
 #' directions determined by `margin_x` and `margin_y`.
 #'
-#' @param grob Text grob to add margins to.
+#' @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

R/theme-defaults.r

@@ -202,6 +202,7 @@ theme_grey <- function(base_size = 11, base_family = "",
                          ),
     strip.text.x =       NULL,
     strip.text.y =       element_text(angle = -90),
+    strip.text.y.left =  element_text(angle = 90),
     strip.placement =    "inside",
     strip.placement.x =  NULL,
     strip.placement.y =  NULL,

R/theme-elements.r

@@ -470,7 +470,11 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) {
   strip.background.x  = el_def("element_rect", "strip.background"),
   strip.background.y  = el_def("element_rect", "strip.background"),
   strip.text.x        = el_def("element_text", "strip.text"),
+  strip.text.x.top    = el_def("element_text", "strip.text.x"),
+  strip.text.x.bottom = el_def("element_text", "strip.text.x"),
   strip.text.y        = el_def("element_text", "strip.text"),
+  strip.text.y.left   = el_def("element_text", "strip.text.y"),
+  strip.text.y.right  = el_def("element_text", "strip.text.y"),
   strip.placement     = el_def("character"),
   strip.placement.x   = el_def("character", "strip.placement"),
   strip.placement.y   = el_def("character", "strip.placement"),