diff --git a/NEWS.md b/NEWS.md index 496195298d..2ce796977a 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 `stat_connect()` to connect points via steps or other shapes (@teunbrand, #6228) * Fixed regression with incorrectly drawn gridlines when using `coord_flip()` diff --git a/R/facet-.R b/R/facet-.R index 0c120beba3..16647b5f07 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -872,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 b41bbbac42..86bbad2b04 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")` @@ -282,69 +293,8 @@ 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) - } - - # 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 - }, + map_data = map_facet_data, attach_axes = function(table, layout, ranges, coord, theme, params) { 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 bbe121d37b..e1eda21cdb 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")` @@ -247,42 +256,8 @@ 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) - } - - 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 - }, + map_data = map_facet_data, attach_axes = function(table, layout, ranges, coord, theme, params) { diff --git a/R/layer.R b/R/layer.R index 9ab02ed96a..cb81e84b58 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 @@ -98,7 +100,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 +134,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 +194,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 ) } @@ -282,6 +285,7 @@ Layer <- ggproto("Layer", NULL, } else { self$computed_mapping <- self$mapping } + attr(data, "layout") <- self$layout data }, 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.} } 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(