diff --git a/NAMESPACE b/NAMESPACE index d6093fe7e9..6a57c5132d 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index 89f06dfb20..4100640a40 100644 --- a/NEWS.md +++ b/NEWS.md @@ -113,6 +113,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 diff --git a/R/facet-.R b/R/facet-.R index f985d84afc..96c96dc6fd 100644 --- a/R/facet-.R +++ b/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) diff --git a/R/facet-grid-.R b/R/facet-grid-.R index 4d4f12f345..f7783f8985 100644 --- a/R/facet-grid-.R +++ b/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) } ) diff --git a/R/facet-wrap.R b/R/facet-wrap.R index 4f07736f7d..68c02f0b21 100644 --- a/R/facet-wrap.R +++ b/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))) } ) diff --git a/man/get_strip_labels.Rd b/man/get_strip_labels.Rd new file mode 100644 index 0000000000..10c3c3c01b --- /dev/null +++ b/man/get_strip_labels.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/facet-.R +\name{get_strip_labels} +\alias{get_strip_labels} +\title{Accessing a plot's facet strip labels} +\usage{ +get_strip_labels(plot = get_last_plot()) +} +\arguments{ +\item{plot}{A ggplot or build ggplot object.} +} +\value{ +\code{NULL} if there are no labels, otherwise a list of data.frames +containing the labels. +} +\description{ +This functions retrieves labels from facet strips with the labeller applied. +} +\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)) +} +\keyword{internal} diff --git a/man/render_strips.Rd b/man/render_strips.Rd index b62a836c8d..468caf6899 100644 --- a/man/render_strips.Rd +++ b/man/render_strips.Rd @@ -4,7 +4,7 @@ \alias{render_strips} \title{Render panel strips} \usage{ -render_strips(x = NULL, y = NULL, labeller, theme) +render_strips(x = NULL, y = NULL, labeller = identity, theme) } \arguments{ \item{x, y}{A data.frame with a column for each variable and a row for each diff --git a/tests/testthat/test-facet-strips.R b/tests/testthat/test-facet-strips.R index ece67935a4..c2f131191e 100644 --- a/tests/testthat/test-facet-strips.R +++ b/tests/testthat/test-facet-strips.R @@ -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") + ) + ) +}) +