From 08a7aabddac32371400caf6ea12b458f180b6920 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 31 May 2024 16:24:46 +0200 Subject: [PATCH 1/5] new format_strip_labels method --- R/facet-.R | 3 +++ R/facet-grid-.R | 27 +++++++++++++++++++++++++++ R/facet-wrap.R | 16 ++++++++++++++++ 3 files changed, 46 insertions(+) diff --git a/R/facet-.R b/R/facet-.R index abdd373d05..b0844d227a 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -175,6 +175,9 @@ Facet <- ggproto("Facet", NULL, }, vars = function() { character(0) + }, + format_strip_labels = function(layout, params) { + return() } ) diff --git a/R/facet-grid-.R b/R/facet-grid-.R index 0854b5299b..31a271a850 100644 --- a/R/facet-grid-.R +++ b/R/facet-grid-.R @@ -506,6 +506,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 720e2e8e37..8e609df713 100644 --- a/R/facet-wrap.R +++ b/R/facet-wrap.R @@ -481,6 +481,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))) } ) From c65055292938df116b3b52177d60556801d59e1b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 31 May 2024 16:25:15 +0200 Subject: [PATCH 2/5] use new method --- R/facet-.R | 2 +- R/facet-grid-.R | 12 +++--------- R/facet-wrap.R | 13 ++----------- 3 files changed, 6 insertions(+), 21 deletions(-) diff --git a/R/facet-.R b/R/facet-.R index b0844d227a..e24a94927a 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -700,7 +700,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 31a271a850..fda111f751 100644 --- a/R/facet-grid-.R +++ b/R/facet-grid-.R @@ -335,7 +335,7 @@ FacetGrid <- ggproto("FacetGrid", Facet, } data }, - draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { + draw_panels = function(self, panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { if ((params$free$x || params$free$y) && !coord$is_free()) { cli::cli_abort("{.fn {snake_class(coord)}} doesn't support free scales.") } @@ -362,14 +362,8 @@ FacetGrid <- ggproto("FacetGrid", Facet, ranges <- censor_labels(ranges, layout, params$axis_labels) axes <- render_axes(ranges[cols], ranges[rows], coord, theme, transpose = TRUE) - col_vars <- unique0(layout[names(params$cols)]) - row_vars <- unique0(layout[names(params$rows)]) - # Adding labels metadata, useful for labellers - attr(col_vars, "type") <- "cols" - attr(col_vars, "facet") <- "grid" - attr(row_vars, "type") <- "rows" - attr(row_vars, "facet") <- "grid" - strips <- render_strips(col_vars, row_vars, params$labeller, theme) + strips <- self$format_strip_labels(layout, params) + strips <- render_strips(strips$cols, strips$rows, theme = theme) aspect_ratio <- theme$aspect.ratio if (!is.null(aspect_ratio) && (params$space_free$x || params$space_free$y)) { diff --git a/R/facet-wrap.R b/R/facet-wrap.R index 8e609df713..31be9a0443 100644 --- a/R/facet-wrap.R +++ b/R/facet-wrap.R @@ -293,17 +293,8 @@ FacetWrap <- ggproto("FacetWrap", Facet, ranges <- censor_labels(ranges, layout, params$axis_labels) axes <- render_axes(ranges, ranges, coord, theme, transpose = TRUE) - if (length(params$facets) == 0) { - # Add a dummy label - labels_df <- data_frame0("(all)" = "(all)", .size = 1) - } else { - labels_df <- layout[names(params$facets)] - } - attr(labels_df, "facet") <- "wrap" - strips <- render_strips( - structure(labels_df, type = "rows"), - structure(labels_df, type = "cols"), - params$labeller, theme) + strips <- self$format_strip_labels(layout, params) + strips <- render_strips(strips$facets, strips$facets, theme = theme) # If user hasn't set aspect ratio, ask the coordinate system if # it wants to specify one From abcea2b278ebd4b51df0baa2b3104ce1e8a2b678 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 31 May 2024 16:28:30 +0200 Subject: [PATCH 3/5] new accessor function --- NAMESPACE | 1 + R/facet-.R | 25 +++++++++++++++++++++++++ man/get_strip_labels.Rd | 28 ++++++++++++++++++++++++++++ man/render_strips.Rd | 2 +- 4 files changed, 55 insertions(+), 1 deletion(-) create mode 100644 man/get_strip_labels.Rd diff --git a/NAMESPACE b/NAMESPACE index 9068973de0..cc6be3d571 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/R/facet-.R b/R/facet-.R index e24a94927a..af16584659 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -242,6 +242,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? #' 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 From 2e5ff706360e8a3b4848c69a446c7ee9d4ef2f52 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 31 May 2024 16:33:22 +0200 Subject: [PATCH 4/5] add test --- tests/testthat/test-facet-strips.R | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/tests/testthat/test-facet-strips.R b/tests/testthat/test-facet-strips.R index 1ee8792e99..3ed1915a7f 100644 --- a/tests/testthat/test-facet-strips.R +++ b/tests/testthat/test-facet-strips.R @@ -193,3 +193,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") + ) + ) +}) + From db599f9a41be57c1482d4a9553c3db17e27f3b1e Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 31 May 2024 16:48:16 +0200 Subject: [PATCH 5/5] add news bullet --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index de3e87cee3..21629a4be1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # ggplot2 (development version) +* New function `get_strip_labels()` to retrieve facet labels (@teunbrand, #4979) * The `arrow.fill` parameter is now applied to more line-based functions: `geom_path()`, `geom_line()`, `geom_step()` `geom_function()`, line geometries in `geom_sf()` and `element_line()`.