Strip label accessor (#5924)

* new format_strip_labels method

* use new method

* new accessor function

* add test

* add news bullet

Author: teunbrand

NAMESPACE

@@ -427,6 +427,7 @@ export(get_last_plot)
 export(get_layer_data)
 export(get_layer_grob)
 export(get_panel_scales)
+export(get_strip_labels)
 export(get_theme)
 export(gg_dep)
 export(gg_par)

NEWS.md

@@ -119,6 +119,7 @@
   are not of the correct length (#5901).
 * `geom_hline()` and `geom_vline()` now have `position` argument
   (@yutannihilation, #4285).
+* New function `get_strip_labels()` to retrieve facet labels (@teunbrand, #4979)
 
 # ggplot2 3.5.1
 

R/facet-.R

@@ -257,6 +257,9 @@ Facet <- ggproto("Facet", NULL,
   },
   vars = function() {
     character(0)
+  },
+  format_strip_labels = function(layout, params) {
+    return()
   }
 )
 
@@ -321,6 +324,31 @@ vars <- function(...) {
   quos(...)
 }
 
+#' Accessing a plot's facet strip labels
+#'
+#' This functions retrieves labels from facet strips with the labeller applied.
+#'
+#' @param plot A ggplot or build ggplot object.
+#'
+#' @return `NULL` if there are no labels, otherwise a list of data.frames
+#'   containing the labels.
+#' @export
+#' @keywords internal
+#'
+#' @examples
+#' # Basic plot
+#' p <- ggplot(mpg, aes(displ, hwy)) +
+#'   geom_point()
+#'
+#' get_strip_labels(p) # empty facets
+#' get_strip_labels(p + facet_wrap(year ~ cyl))
+#' get_strip_labels(p + facet_grid(year ~ cyl))
+get_strip_labels <- function(plot = get_last_plot()) {
+  plot   <- ggplot_build(plot)
+  layout <- plot$layout$layout
+  params <- plot$layout$facet_params
+  plot$plot$facet$format_strip_labels(layout, params)
+}
 
 #' Is this object a faceting specification?
 #'
@@ -779,7 +807,7 @@ render_axes <- function(x = NULL, y = NULL, coord, theme, transpose = FALSE) {
 #'
 #' @keywords internal
 #' @export
-render_strips <- function(x = NULL, y = NULL, labeller, theme) {
+render_strips <- function(x = NULL, y = NULL, labeller = identity, theme) {
   list(
     x = build_strip(x, labeller, theme, TRUE),
     y = build_strip(y, labeller, theme, FALSE)

R/facet-grid-.R

@@ -380,16 +380,11 @@ FacetGrid <- ggproto("FacetGrid", Facet,
     table
   },
 
-  attach_strips = function(table, layout, params, theme) {
+  attach_strips = function(self, table, layout, params, theme) {
 
-    col_vars <- unique0(layout[names(params$cols)])
-    row_vars <- unique0(layout[names(params$rows)])
-    attr(col_vars, "type")  <- "cols"
-    attr(row_vars, "type")  <- "rows"
-    attr(col_vars, "facet") <- "grid"
-    attr(row_vars, "facet") <- "grid"
+    strips <- self$format_strip_labels(layout, params)
+    strips <- render_strips(strips$cols, strips$rows, theme = theme)
 
-    strips  <- render_strips(col_vars, row_vars, params$labeller, theme)
     padding <- convertUnit(calc_element("strip.switch.pad.grid", theme), "cm")
 
     switch_x <- !is.null(params$switch) && params$switch %in% c("both", "x")
@@ -432,6 +427,33 @@ FacetGrid <- ggproto("FacetGrid", Facet,
 
   vars = function(self) {
     names(c(self$params$rows, self$params$cols))
+  },
+
+  format_strip_labels = function(layout, params) {
+
+    labeller <- match.fun(params$labeller)
+
+    cols <- intersect(names(layout), names(params$cols))
+    if (length(cols) > 0) {
+      col_vars <- unique0(layout[cols])
+      attr(col_vars, "type")  <- "cols"
+      attr(col_vars, "facet") <- "grid"
+      cols <- data_frame0(!!!labeller(col_vars))
+    } else {
+      cols <- NULL
+    }
+
+    rows <- intersect(names(layout), names(params$rows))
+    if (length(rows) > 0) {
+      row_vars <- unique0(layout[rows])
+      attr(row_vars, "type")  <- "rows"
+      attr(row_vars, "facet") <- "grid"
+      rows <- data_frame0(!!!labeller(row_vars))
+    } else {
+      rows <- NULL
+    }
+
+    list(cols = cols, rows = rows)
   }
 )
 

R/facet-wrap.R

@@ -371,22 +371,11 @@ FacetWrap <- ggproto("FacetWrap", Facet,
     weave_axes(table, axes, empty)
   },
 
-  attach_strips = function(table, layout, params, theme) {
+  attach_strips = function(self, table, layout, params, theme) {
 
     # Format labels
-    if (length(params$facets) == 0) {
-      labels <- data_frame0("(all)" = "(all)", .size = 1)
-    } else {
-      labels <- layout[names(params$facets)]
-    }
-    attr(labels, "facet") <- "wrap"
-
-    # Render individual strips
-    strips <- render_strips(
-      x = structure(labels, type = "rows"),
-      y = structure(labels, type = "cols"),
-      params$labeller, theme
-    )
+    strips <- self$format_strip_labels(layout, params)
+    strips <- render_strips(strips$facets, strips$facets, theme = theme)
 
     # Set position invariant parameters
     padding  <- convertUnit(calc_element("strip.switch.pad.wrap", theme), "cm")
@@ -457,6 +446,22 @@ FacetWrap <- ggproto("FacetWrap", Facet,
   },
   vars = function(self) {
     names(self$params$facets)
+  },
+
+  format_strip_labels = function(layout, params) {
+    if (length(params$facets) == 0) {
+      labels <- data_frame0("(all)" = "(all)", .size = 1)
+    } else {
+      labels <- layout[intersect(names(params$facets), names(layout))]
+    }
+    if (empty(labels)) {
+      return(NULL)
+    }
+    attr(labels, "facet") <- "wrap"
+    attr(labels, "type") <- switch(params$strip.position, left = , right = "rows", "cols")
+
+    labeller <- match.fun(params$labeller)
+    list(facets = data_frame0(!!!labeller(labels)))
   }
 )
 

man/get_strip_labels.Rd

@@ -209,3 +209,21 @@ test_that("strip clipping can be set from the theme", {
   expect_equal(strip$x$top[[1]]$layout$clip, "off")
 })
 
+test_that("strip labels can be accessed", {
+
+  expect_null(get_strip_labels(ggplot()))
+
+  expect_equal(
+    get_strip_labels(ggplot() + facet_wrap(vars("X", "Y"))),
+    list(facets = data_frame0(`"X"` = "X", `"Y"` = "Y"))
+  )
+
+  expect_equal(
+    get_strip_labels(ggplot() + facet_grid(vars("X"), vars("Y"))),
+    list(
+      cols = data_frame0(`"Y"` = "Y"),
+      rows = data_frame0(`"X"` = "X")
+    )
+  )
+})
+