From 1bdf9484894acce7127b2d23c918b7e8b4d104c3 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 18 Feb 2025 15:36:16 +0100 Subject: [PATCH 1/9] append layout attribute to layer data --- R/layer.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/R/layer.R b/R/layer.R index 6be74b5d72..65bfa62637 100644 --- a/R/layer.R +++ b/R/layer.R @@ -98,7 +98,7 @@ layer <- function(geom = NULL, stat = NULL, data = NULL, mapping = NULL, position = NULL, params = list(), inherit.aes = TRUE, check.aes = TRUE, check.param = TRUE, - show.legend = NA, key_glyph = NULL, layer_class = Layer) { + show.legend = NA, key_glyph = NULL, layout = NULL, layer_class = Layer) { call_env <- caller_env() user_env <- caller_env(2) @@ -132,7 +132,7 @@ layer <- function(geom = NULL, stat = NULL, geom_params <- params[intersect(names(params), geom$parameters(TRUE))] stat_params <- params[intersect(names(params), stat$parameters(TRUE))] - ignore <- c("key_glyph", "name") + ignore <- c("key_glyph", "name", "layout") all <- c(geom$parameters(TRUE), stat$parameters(TRUE), geom$aesthetics(), position$aesthetics(), ignore) # Take care of plain patterns provided as aesthetic @@ -192,7 +192,8 @@ layer <- function(geom = NULL, stat = NULL, position = position, inherit.aes = inherit.aes, show.legend = show.legend, - name = params$name + name = params$name, + layout = layout %||% params$layout ) } @@ -280,6 +281,7 @@ Layer <- ggproto("Layer", NULL, } else { self$computed_mapping <- self$mapping } + attr(data, "layout") <- self$layout data }, From 28ba95188060805208e77bdd32671cff92d5220d Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 18 Feb 2025 15:40:50 +0100 Subject: [PATCH 2/9] repeat data for fixed layout --- R/facet-grid-.R | 8 ++++++++ R/facet-wrap.R | 8 ++++++++ 2 files changed, 16 insertions(+) diff --git a/R/facet-grid-.R b/R/facet-grid-.R index ff5cdf0d81..522e0f4c4a 100644 --- a/R/facet-grid-.R +++ b/R/facet-grid-.R @@ -297,6 +297,14 @@ FacetGrid <- ggproto("FacetGrid", Facet, return(data) } + layer_layout <- attr(data, "layout") + if (identical(layer_layout, "fixed")) { + n <- vec_size(data) + data <- vec_rep(data, nrow(layout)) + data$PANEL <- vec_rep_each(layout$PANEL, n) + return(data) + } + # Compute faceting values facet_vals <- eval_facets(c(rows, cols), data, params$.possible_columns) if (nrow(facet_vals) == nrow(data)) { diff --git a/R/facet-wrap.R b/R/facet-wrap.R index 6bc72f8af4..79df74bef0 100644 --- a/R/facet-wrap.R +++ b/R/facet-wrap.R @@ -258,6 +258,14 @@ FacetWrap <- ggproto("FacetWrap", Facet, return(data) } + layer_layout <- attr(data, "layout") + if (identical(layer_layout, "fixed")) { + n <- vec_size(data) + data <- vec_rep(data, nrow(layout)) + data$PANEL <- vec_rep_each(layout$PANEL, n) + return(data) + } + facet_vals <- eval_facets(vars, data, params$.possible_columns) facet_vals[] <- lapply(facet_vals[], as_unordered_factor) layout[] <- lapply(layout[], as_unordered_factor) From c0ba01c5e24f4f76fcfa27d127ab7a82d6c025b7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 18 Feb 2025 16:32:36 +0100 Subject: [PATCH 3/9] unify `Facet$map_data()` approaches --- R/facet-.R | 64 +++++++++++++++++++++++++++++++++++++++++++- R/facet-grid-.R | 71 ------------------------------------------------- R/facet-wrap.R | 44 ------------------------------ 3 files changed, 63 insertions(+), 116 deletions(-) diff --git a/R/facet-.R b/R/facet-.R index 0c120beba3..6da48cc77a 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -88,7 +88,69 @@ Facet <- ggproto("Facet", NULL, cli::cli_abort("Not implemented.") }, map_data = function(data, layout, params) { - cli::cli_abort("Not implemented.") + + if (empty(data)) { + return(vec_cbind(data %|W|% NULL, PANEL = integer(0))) + } + + vars <- params$facet %||% c(params$rows, params$cols) + + if (length(vars) == 0) { + data$PANEL <- layout$PANEL + return(data) + } + + layer_layout <- attr(data, "layout") + if (identical(layer_layout, "fixed")) { + n <- vec_size(data) + data <- vec_rep(data, vec_size(layout)) + data$PANEL <- vec_rep_each(layout$PANEL, n) + return(data) + } + + facet_vals <- eval_facets(vars, data, params$.possible_columns) + + include_margins <- !isFALSE(params$margin %||% FALSE) && + nrow(facet_vals) == nrow(data) && + all(c("rows", "cols") %in% names(params)) + if (include_margins) { + facet_vals <- reshape_add_margins( + vec_cbind(facet_vals, .index = seq_len(nrow(facet_vals))), + list(intersect(names(params$rows), names(facet_vals)), + intersect(names(params$cols), names(facet_vals))), + params$margins %||% FALSE + ) + data <- data[facet_vals$.index, , drop = FALSE] + facet_vals$.index <- NULL + } + + missing_facets <- setdiff(names(vars), names(facet_vals)) + if (length(missing_facets) > 0) { + + to_add <- unique0(layout[missing_facets]) + + data_rep <- rep.int(seq_len(nrow(data)), nrow(to_add)) + facet_rep <- rep(seq_len(nrow(to_add)), each = nrow(data)) + + data <- unrowname(data[data_rep, , drop = FALSE]) + facet_vals <- unrowname(vec_cbind( + unrowname(facet_vals[data_rep, , drop = FALSE]), + unrowname(to_add[facet_rep, , drop = FALSE]) + )) + } + + if (nrow(facet_vals) < 1) { + data$PANEL <- NO_PANEL + return(data) + } + + facet_vals[] <- lapply(facet_vals, as_unordered_factor) + facet_vals[] <- lapply(facet_vals, addNA, ifany = TRUE) + layout[] <- lapply(layout, as_unordered_factor) + + keys <- join_keys(facet_vals, layout, by = names(vars)) + data$PANEL <- layout$PANEL[match(keys$x, keys$y)] + data }, init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) { scales <- list() diff --git a/R/facet-grid-.R b/R/facet-grid-.R index 522e0f4c4a..65dfc122fc 100644 --- a/R/facet-grid-.R +++ b/R/facet-grid-.R @@ -283,77 +283,6 @@ FacetGrid <- ggproto("FacetGrid", Facet, panels }, - map_data = function(data, layout, params) { - if (empty(data)) { - return(vec_cbind(data %|W|% NULL, PANEL = integer(0))) - } - - rows <- params$rows - cols <- params$cols - vars <- c(names(rows), names(cols)) - - if (length(vars) == 0) { - data$PANEL <- layout$PANEL - return(data) - } - - layer_layout <- attr(data, "layout") - if (identical(layer_layout, "fixed")) { - n <- vec_size(data) - data <- vec_rep(data, nrow(layout)) - data$PANEL <- vec_rep_each(layout$PANEL, n) - return(data) - } - - # Compute faceting values - facet_vals <- eval_facets(c(rows, cols), data, params$.possible_columns) - if (nrow(facet_vals) == nrow(data)) { - # Margins are computed on evaluated faceting values (#1864). - facet_vals <- reshape_add_margins( - # We add an index column to track data recycling - vec_cbind(facet_vals, .index = seq_len(nrow(facet_vals))), - list(intersect(names(rows), names(facet_vals)), - intersect(names(cols), names(facet_vals))), - params$margins - ) - # Apply recycling on original data to fit margins - # We're using base subsetting here because `data` might have a superclass - # that isn't handled well by vctrs::vec_slice - data <- data[facet_vals$.index, , drop = FALSE] - facet_vals$.index <- NULL - } - - # If any faceting variables are missing, add them in by - # duplicating the data - missing_facets <- setdiff(vars, names(facet_vals)) - if (length(missing_facets) > 0) { - to_add <- unique0(layout[missing_facets]) - - data_rep <- rep.int(seq_len(nrow(data)), nrow(to_add)) - facet_rep <- rep(seq_len(nrow(to_add)), each = nrow(data)) - - data <- unrowname(data[data_rep, , drop = FALSE]) - facet_vals <- unrowname(vec_cbind( - unrowname(facet_vals[data_rep, , drop = FALSE]), - unrowname(to_add[facet_rep, , drop = FALSE])) - ) - } - - # Add PANEL variable - if (nrow(facet_vals) == 0) { - # Special case of no faceting - data$PANEL <- NO_PANEL - } else { - facet_vals[] <- lapply(facet_vals[], as_unordered_factor) - facet_vals[] <- lapply(facet_vals[], addNA, ifany = TRUE) - layout[] <- lapply(layout[], as_unordered_factor) - - keys <- join_keys(facet_vals, layout, by = vars) - - data$PANEL <- layout$PANEL[match(keys$x, keys$y)] - } - data - }, attach_axes = function(table, layout, ranges, coord, theme, params) { diff --git a/R/facet-wrap.R b/R/facet-wrap.R index 79df74bef0..f60b52d747 100644 --- a/R/facet-wrap.R +++ b/R/facet-wrap.R @@ -246,50 +246,6 @@ FacetWrap <- ggproto("FacetWrap", Facet, panels }, - map_data = function(data, layout, params) { - if (empty(data)) { - return(vec_cbind(data %|W|% NULL, PANEL = integer(0))) - } - - vars <- params$facets - - if (length(vars) == 0) { - data$PANEL <- layout$PANEL - return(data) - } - - layer_layout <- attr(data, "layout") - if (identical(layer_layout, "fixed")) { - n <- vec_size(data) - data <- vec_rep(data, nrow(layout)) - data$PANEL <- vec_rep_each(layout$PANEL, n) - return(data) - } - - facet_vals <- eval_facets(vars, data, params$.possible_columns) - facet_vals[] <- lapply(facet_vals[], as_unordered_factor) - layout[] <- lapply(layout[], as_unordered_factor) - - missing_facets <- setdiff(names(vars), names(facet_vals)) - if (length(missing_facets) > 0) { - - to_add <- unique0(layout[missing_facets]) - - data_rep <- rep.int(seq_len(nrow(data)), nrow(to_add)) - facet_rep <- rep(seq_len(nrow(to_add)), each = nrow(data)) - - data <- data[data_rep, , drop = FALSE] - facet_vals <- vec_cbind( - facet_vals[data_rep, , drop = FALSE], - to_add[facet_rep, , drop = FALSE] - ) - } - - keys <- join_keys(facet_vals, layout, by = names(vars)) - - data$PANEL <- layout$PANEL[match(keys$x, keys$y)] - data - }, attach_axes = function(table, layout, ranges, coord, theme, params) { From 8d9d95595f3ce4219a7ef417d12b187884bb8929 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 26 Feb 2025 13:42:40 +0100 Subject: [PATCH 4/9] put comments back in --- R/facet-.R | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/R/facet-.R b/R/facet-.R index 6da48cc77a..3c1cc2856f 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -108,22 +108,29 @@ Facet <- ggproto("Facet", NULL, return(data) } + # Compute faceting values facet_vals <- eval_facets(vars, data, params$.possible_columns) include_margins <- !isFALSE(params$margin %||% FALSE) && nrow(facet_vals) == nrow(data) && all(c("rows", "cols") %in% names(params)) if (include_margins) { + # Margins are computed on evaluated faceting values (#1864). facet_vals <- reshape_add_margins( vec_cbind(facet_vals, .index = seq_len(nrow(facet_vals))), list(intersect(names(params$rows), names(facet_vals)), intersect(names(params$cols), names(facet_vals))), params$margins %||% FALSE ) + # Apply recycling on original data to fit margins + # We're using base subsetting here because `data` might have a superclass + # that isn't handled well by vctrs::vec_slice data <- data[facet_vals$.index, , drop = FALSE] facet_vals$.index <- NULL } + # If any faceting variables are missing, add them in by + # duplicating the data missing_facets <- setdiff(names(vars), names(facet_vals)) if (length(missing_facets) > 0) { @@ -140,6 +147,7 @@ Facet <- ggproto("Facet", NULL, } if (nrow(facet_vals) < 1) { + # Add PANEL variable data$PANEL <- NO_PANEL return(data) } @@ -148,6 +156,7 @@ Facet <- ggproto("Facet", NULL, facet_vals[] <- lapply(facet_vals, addNA, ifany = TRUE) layout[] <- lapply(layout, as_unordered_factor) + # Add PANEL variable keys <- join_keys(facet_vals, layout, by = names(vars)) data$PANEL <- layout$PANEL[match(keys$x, keys$y)] data From f7feb8cd2dd49eb1f4dbfa2e2dc0f394d4a414e1 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 26 Feb 2025 14:00:20 +0100 Subject: [PATCH 5/9] Implement keywords for fixing rows / columns --- R/facet-.R | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/R/facet-.R b/R/facet-.R index 3c1cc2856f..fcdf8a3da6 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -100,6 +100,7 @@ Facet <- ggproto("Facet", NULL, return(data) } + grid_layout <- all(c("rows", "cols") %in% names(params)) layer_layout <- attr(data, "layout") if (identical(layer_layout, "fixed")) { n <- vec_size(data) @@ -112,8 +113,7 @@ Facet <- ggproto("Facet", NULL, facet_vals <- eval_facets(vars, data, params$.possible_columns) include_margins <- !isFALSE(params$margin %||% FALSE) && - nrow(facet_vals) == nrow(data) && - all(c("rows", "cols") %in% names(params)) + nrow(facet_vals) == nrow(data) && grid_layout if (include_margins) { # Margins are computed on evaluated faceting values (#1864). facet_vals <- reshape_add_margins( @@ -129,6 +129,17 @@ Facet <- ggproto("Facet", NULL, facet_vals$.index <- NULL } + # If we need to fix rows or columns, we make the corresponding faceting + # variables missing on purpose + if (grid_layout) { + if (identical(layer_layout, "fixed_rows")) { + facet_vals <- facet_vals[setdiff(names(facet_vals), names(params$cols))] + } + if (identical(layer_layout, "fixed_cols")) { + facet_vals <- facet_vals[setdiff(names(facet_vals), names(params$rows))] + } + } + # If any faceting variables are missing, add them in by # duplicating the data missing_facets <- setdiff(names(vars), names(facet_vals)) From 7ae5358bf32eb5288f75fc333bbd5dea9e197e52 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 26 Feb 2025 15:08:59 +0100 Subject: [PATCH 6/9] use integers to select panels --- R/facet-.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/R/facet-.R b/R/facet-.R index fcdf8a3da6..850c715bab 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -170,6 +170,12 @@ Facet <- ggproto("Facet", NULL, # Add PANEL variable keys <- join_keys(facet_vals, layout, by = names(vars)) data$PANEL <- layout$PANEL[match(keys$x, keys$y)] + + # Filter panels when layer_layout is an integer + if (is_integerish(layer_layout)) { + data <- vec_slice(data, data$PANEL %in% layer_layout) + } + data }, init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) { From b9edb48b2bf4ea6c3ed4559db411e2f06397cdb8 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 26 Feb 2025 15:09:16 +0100 Subject: [PATCH 7/9] document the use of the `layout` argument --- R/facet-grid-.R | 11 +++++++++++ R/facet-null.R | 3 +++ R/facet-wrap.R | 9 +++++++++ R/layer.R | 2 ++ man/facet_grid.Rd | 14 ++++++++++++++ man/facet_null.Rd | 6 ++++++ man/facet_wrap.Rd | 12 ++++++++++++ man/layer.Rd | 4 ++++ 8 files changed, 61 insertions(+) diff --git a/R/facet-grid-.R b/R/facet-grid-.R index 65dfc122fc..6f3c24effd 100644 --- a/R/facet-grid-.R +++ b/R/facet-grid-.R @@ -69,6 +69,17 @@ NULL #' labels and the interior axes get none. When `"all_x"` or `"all_y"`, only #' draws the labels at the interior axes in the x- or y-direction #' respectively. +#' +#' @section Layer layout: +#' The [`layer(layout)`][layer()] argument in context of `facet_grid()` can take +#' the following values: +#' * `NULL` (default) to use the faceting variables to assign panels. +#' * An integer vector to include selected panels. Panel numbers not included in +#' the integer vector are excluded. +#' * `"fixed"` to repeat data across every panel. +#' * `"fixed_rows"` to repeat data across rows. +#' * `"fixed_cols"` to repeat data across columns. +#' #' @export #' @seealso #' The `r link_book("facet grid section", "facet#facet-grid")` diff --git a/R/facet-null.R b/R/facet-null.R index e263bf0453..26b610fdfa 100644 --- a/R/facet-null.R +++ b/R/facet-null.R @@ -6,6 +6,9 @@ NULL #' @inheritParams facet_grid #' @keywords internal #' @export +#' @section Layer layout: +#' The [`layer(layout)`][layer()] argument in context of `facet_null()` is +#' completely ignored. #' @examples #' # facet_null is the default faceting specification if you #' # don't override it with facet_grid or facet_wrap diff --git a/R/facet-wrap.R b/R/facet-wrap.R index f60b52d747..725764af34 100644 --- a/R/facet-wrap.R +++ b/R/facet-wrap.R @@ -45,6 +45,15 @@ NULL #' the exterior axes get labels, and the interior axes get none. When #' `"all_x"` or `"all_y"`, only draws the labels at the interior axes in the #' x- or y-direction respectively. +#' +#' @section Layer layout: +#' The [`layer(layout)`][layer()] argument in context of `facet_wrap()` can take +#' the following values: +#' * `NULL` (default) to use the faceting variables to assign panels. +#' * An integer vector to include selected panels. Panel numbers not included in +#' the integer vector are excluded. +#' * `"fixed"` to repeat data across every panel. +#' #' @inheritParams facet_grid #' @seealso #' The `r link_book("facet wrap section", "facet#sec-facet-wrap")` diff --git a/R/layer.R b/R/layer.R index 65bfa62637..cf6752be1b 100644 --- a/R/layer.R +++ b/R/layer.R @@ -71,6 +71,8 @@ #' @param params Additional parameters to the `geom` and `stat`. #' @param key_glyph A legend key drawing function or a string providing the #' function name minus the `draw_key_` prefix. See [draw_key] for details. +#' @param layout Argument to control layout at the layer level. Consult the +#' faceting documentation to view appropriate values. #' @param layer_class The type of layer object to be constructed. This is #' intended for ggplot2 internal use only. #' @keywords internal diff --git a/man/facet_grid.Rd b/man/facet_grid.Rd index e0a3cd1e1b..df687239a1 100644 --- a/man/facet_grid.Rd +++ b/man/facet_grid.Rd @@ -100,6 +100,20 @@ faceting variables. It is most useful when you have two discrete variables, and all combinations of the variables exist in the data. If you have only one variable with many levels, try \code{\link[=facet_wrap]{facet_wrap()}}. } +\section{Layer layout}{ + +The \code{\link[=layer]{layer(layout)}} argument in context of \code{facet_grid()} can take +the following values: +\itemize{ +\item \code{NULL} (default) to use the faceting variables to assign panels. +\item An integer vector to include selected panels. Panel numbers not included in +the integer vector are excluded. +\item \code{"fixed"} to repeat data across every panel. +\item \code{"fixed_rows"} to repeat data across rows. +\item \code{"fixed_cols"} to repeat data across columns. +} +} + \examples{ p <- ggplot(mpg, aes(displ, cty)) + geom_point() diff --git a/man/facet_null.Rd b/man/facet_null.Rd index 3e1c058771..9e0f0ba3d6 100644 --- a/man/facet_null.Rd +++ b/man/facet_null.Rd @@ -14,6 +14,12 @@ before statistical summary.} \description{ Facet specification: a single panel. } +\section{Layer layout}{ + +The \code{\link[=layer]{layer(layout)}} argument in context of \code{facet_null()} is +completely ignored. +} + \examples{ # facet_null is the default faceting specification if you # don't override it with facet_grid or facet_wrap diff --git a/man/facet_wrap.Rd b/man/facet_wrap.Rd index 66716f5c5f..4cfcf1284e 100644 --- a/man/facet_wrap.Rd +++ b/man/facet_wrap.Rd @@ -102,6 +102,18 @@ x- or y-direction respectively.} a better use of screen space than \code{\link[=facet_grid]{facet_grid()}} because most displays are roughly rectangular. } +\section{Layer layout}{ + +The \code{\link[=layer]{layer(layout)}} argument in context of \code{facet_wrap()} can take +the following values: +\itemize{ +\item \code{NULL} (default) to use the faceting variables to assign panels. +\item An integer vector to include selected panels. Panel numbers not included in +the integer vector are excluded. +\item \code{"fixed"} to repeat data across every panel. +} +} + \examples{ p <- ggplot(mpg, aes(displ, hwy)) + geom_point() diff --git a/man/layer.Rd b/man/layer.Rd index e34ee05245..79d9afbe57 100644 --- a/man/layer.Rd +++ b/man/layer.Rd @@ -16,6 +16,7 @@ layer( check.param = TRUE, show.legend = NA, key_glyph = NULL, + layout = NULL, layer_class = Layer ) } @@ -101,6 +102,9 @@ but unobserved levels are omitted.} \item{key_glyph}{A legend key drawing function or a string providing the function name minus the \code{draw_key_} prefix. See \link{draw_key} for details.} +\item{layout}{Argument to control layout at the layer level. Consult the +faceting documentation to view appropriate values.} + \item{layer_class}{The type of layer object to be constructed. This is intended for ggplot2 internal use only.} } From b3bb6756060c5dc5efd3834ef00d8a63665f493a Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 26 Feb 2025 15:30:43 +0100 Subject: [PATCH 8/9] add news bullet --- NEWS.md | 1 + tests/testthat/test-facet-map.R | 61 +++++++++++++++++++++++++++++++++ 2 files changed, 62 insertions(+) diff --git a/NEWS.md b/NEWS.md index 74b049ace5..3a43621070 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # ggplot2 (development version) +* New `layer(layout)` argument to interact with facets (@teunbrand, #3062) * New parameters for `geom_label()` (@teunbrand and @steveharoz, #5365): * The `linewidth` aesthetic is now applied and replaces the `label.size` argument. diff --git a/tests/testthat/test-facet-map.R b/tests/testthat/test-facet-map.R index de2bf20af2..d6d1d0c79a 100644 --- a/tests/testthat/test-facet-map.R +++ b/tests/testthat/test-facet-map.R @@ -93,6 +93,67 @@ test_that("wrap and grid can facet by a POSIXct variable", { expect_equal(loc_grid_row$PANEL, factor(1:3)) }) +test_that("wrap: layer layout is respected", { + + df <- expand.grid(x = LETTERS[1:2], y = 1:3) + + p <- ggplot(df, aes(x, y)) + + geom_point(colour = "red", layout = "fixed") + + geom_point() + + geom_point(colour = "blue", layout = 5) + + facet_wrap(~ x + y) + b <- ggplot_build(p) + + expect_equal( + table(get_layer_data(b, i = 1L)$PANEL), + table(rep(1:6, 6)) + ) + expect_equal( + table(get_layer_data(b, i = 2L)$PANEL), + table(1:6) + ) + expect_equal( + table(get_layer_data(b, i = 3L)$PANEL), + table(factor(5, levels = 1:6)) + ) +}) + +test_that("grid: layer layout is respected", { + + df <- expand.grid(x = LETTERS[1:2], y = 1:3) + + p <- ggplot(df, aes(x, y)) + + geom_point(colour = "red", layout = "fixed") + + geom_point(colour = "green", layout = "fixed_rows") + + geom_point(colour = "purple", layout = "fixed_cols") + + geom_point() + + geom_point(colour = "blue", layout = 5) + + facet_grid(x ~ y) + b <- ggplot_build(p) + + expect_equal( + table(get_layer_data(b, i = 1L)$PANEL), + table(rep(1:6, 6)) + ) + expect_equal( + table(get_layer_data(b, i = 2L)$PANEL), + table(rep(1:6, 3)) + ) + expect_equal( + table(get_layer_data(b, i = 3L)$PANEL), + table(rep(1:6, 2)) + ) + expect_equal( + table(get_layer_data(b, i = 4L)$PANEL), + table(1:6) + ) + expect_equal( + table(get_layer_data(b, i = 5L)$PANEL), + table(factor(5, levels = 1:6)) + ) +}) + + # Missing behaviour ---------------------------------------------------------- a3 <- data_frame( From 24f95ae8650701e2b5c216ef0f0144e41aa9f062 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 25 Mar 2025 14:37:15 +0100 Subject: [PATCH 9/9] swap facet data mapping from method to standalone function --- R/facet-.R | 182 +++++++++++++++++++++++++----------------------- R/facet-grid-.R | 2 + R/facet-wrap.R | 2 + 3 files changed, 97 insertions(+), 89 deletions(-) diff --git a/R/facet-.R b/R/facet-.R index 850c715bab..16647b5f07 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -88,95 +88,7 @@ Facet <- ggproto("Facet", NULL, cli::cli_abort("Not implemented.") }, map_data = function(data, layout, params) { - - if (empty(data)) { - return(vec_cbind(data %|W|% NULL, PANEL = integer(0))) - } - - vars <- params$facet %||% c(params$rows, params$cols) - - if (length(vars) == 0) { - data$PANEL <- layout$PANEL - return(data) - } - - grid_layout <- all(c("rows", "cols") %in% names(params)) - layer_layout <- attr(data, "layout") - if (identical(layer_layout, "fixed")) { - n <- vec_size(data) - data <- vec_rep(data, vec_size(layout)) - data$PANEL <- vec_rep_each(layout$PANEL, n) - return(data) - } - - # Compute faceting values - facet_vals <- eval_facets(vars, data, params$.possible_columns) - - include_margins <- !isFALSE(params$margin %||% FALSE) && - nrow(facet_vals) == nrow(data) && grid_layout - if (include_margins) { - # Margins are computed on evaluated faceting values (#1864). - facet_vals <- reshape_add_margins( - vec_cbind(facet_vals, .index = seq_len(nrow(facet_vals))), - list(intersect(names(params$rows), names(facet_vals)), - intersect(names(params$cols), names(facet_vals))), - params$margins %||% FALSE - ) - # Apply recycling on original data to fit margins - # We're using base subsetting here because `data` might have a superclass - # that isn't handled well by vctrs::vec_slice - data <- data[facet_vals$.index, , drop = FALSE] - facet_vals$.index <- NULL - } - - # If we need to fix rows or columns, we make the corresponding faceting - # variables missing on purpose - if (grid_layout) { - if (identical(layer_layout, "fixed_rows")) { - facet_vals <- facet_vals[setdiff(names(facet_vals), names(params$cols))] - } - if (identical(layer_layout, "fixed_cols")) { - facet_vals <- facet_vals[setdiff(names(facet_vals), names(params$rows))] - } - } - - # If any faceting variables are missing, add them in by - # duplicating the data - missing_facets <- setdiff(names(vars), names(facet_vals)) - if (length(missing_facets) > 0) { - - to_add <- unique0(layout[missing_facets]) - - data_rep <- rep.int(seq_len(nrow(data)), nrow(to_add)) - facet_rep <- rep(seq_len(nrow(to_add)), each = nrow(data)) - - data <- unrowname(data[data_rep, , drop = FALSE]) - facet_vals <- unrowname(vec_cbind( - unrowname(facet_vals[data_rep, , drop = FALSE]), - unrowname(to_add[facet_rep, , drop = FALSE]) - )) - } - - if (nrow(facet_vals) < 1) { - # Add PANEL variable - data$PANEL <- NO_PANEL - return(data) - } - - facet_vals[] <- lapply(facet_vals, as_unordered_factor) - facet_vals[] <- lapply(facet_vals, addNA, ifany = TRUE) - layout[] <- lapply(layout, as_unordered_factor) - - # Add PANEL variable - keys <- join_keys(facet_vals, layout, by = names(vars)) - data$PANEL <- layout$PANEL[match(keys$x, keys$y)] - - # Filter panels when layer_layout is an integer - if (is_integerish(layer_layout)) { - data <- vec_slice(data, data$PANEL %in% layer_layout) - } - - data + cli::cli_abort("Not implemented.") }, init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) { scales <- list() @@ -960,3 +872,95 @@ censor_labels <- function(ranges, layout, labels) { } ranges } + +map_facet_data <- function(data, layout, params) { + + if (empty(data)) { + return(vec_cbind(data %|W|% NULL, PANEL = integer(0))) + } + + vars <- params$facet %||% c(params$rows, params$cols) + + if (length(vars) == 0) { + data$PANEL <- layout$PANEL + return(data) + } + + grid_layout <- all(c("rows", "cols") %in% names(params)) + layer_layout <- attr(data, "layout") + if (identical(layer_layout, "fixed")) { + n <- vec_size(data) + data <- vec_rep(data, vec_size(layout)) + data$PANEL <- vec_rep_each(layout$PANEL, n) + return(data) + } + + # Compute faceting values + facet_vals <- eval_facets(vars, data, params$.possible_columns) + + include_margins <- !isFALSE(params$margin %||% FALSE) && + nrow(facet_vals) == nrow(data) && grid_layout + if (include_margins) { + # Margins are computed on evaluated faceting values (#1864). + facet_vals <- reshape_add_margins( + vec_cbind(facet_vals, .index = seq_len(nrow(facet_vals))), + list(intersect(names(params$rows), names(facet_vals)), + intersect(names(params$cols), names(facet_vals))), + params$margins %||% FALSE + ) + # Apply recycling on original data to fit margins + # We're using base subsetting here because `data` might have a superclass + # that isn't handled well by vctrs::vec_slice + data <- data[facet_vals$.index, , drop = FALSE] + facet_vals$.index <- NULL + } + + # If we need to fix rows or columns, we make the corresponding faceting + # variables missing on purpose + if (grid_layout) { + if (identical(layer_layout, "fixed_rows")) { + facet_vals <- facet_vals[setdiff(names(facet_vals), names(params$cols))] + } + if (identical(layer_layout, "fixed_cols")) { + facet_vals <- facet_vals[setdiff(names(facet_vals), names(params$rows))] + } + } + + # If any faceting variables are missing, add them in by + # duplicating the data + missing_facets <- setdiff(names(vars), names(facet_vals)) + if (length(missing_facets) > 0) { + + to_add <- unique0(layout[missing_facets]) + + data_rep <- rep.int(seq_len(nrow(data)), nrow(to_add)) + facet_rep <- rep(seq_len(nrow(to_add)), each = nrow(data)) + + data <- unrowname(data[data_rep, , drop = FALSE]) + facet_vals <- unrowname(vec_cbind( + unrowname(facet_vals[data_rep, , drop = FALSE]), + unrowname(to_add[facet_rep, , drop = FALSE]) + )) + } + + if (nrow(facet_vals) < 1) { + # Add PANEL variable + data$PANEL <- NO_PANEL + return(data) + } + + facet_vals[] <- lapply(facet_vals, as_unordered_factor) + facet_vals[] <- lapply(facet_vals, addNA, ifany = TRUE) + layout[] <- lapply(layout, as_unordered_factor) + + # Add PANEL variable + keys <- join_keys(facet_vals, layout, by = names(vars)) + data$PANEL <- layout$PANEL[match(keys$x, keys$y)] + + # Filter panels when layer_layout is an integer + if (is_integerish(layer_layout)) { + data <- vec_slice(data, data$PANEL %in% layer_layout) + } + + data +} diff --git a/R/facet-grid-.R b/R/facet-grid-.R index 5a763131e4..86bbad2b04 100644 --- a/R/facet-grid-.R +++ b/R/facet-grid-.R @@ -294,6 +294,8 @@ FacetGrid <- ggproto("FacetGrid", Facet, panels }, + map_data = map_facet_data, + attach_axes = function(table, layout, ranges, coord, theme, params) { # Setup parameters diff --git a/R/facet-wrap.R b/R/facet-wrap.R index 4ead619327..e1eda21cdb 100644 --- a/R/facet-wrap.R +++ b/R/facet-wrap.R @@ -257,6 +257,8 @@ FacetWrap <- ggproto("FacetWrap", Facet, panels }, + map_data = map_facet_data, + attach_axes = function(table, layout, ranges, coord, theme, params) { # Setup parameters