Layer parameter controlling facet layout

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.

R/facet-.R

@@ -88,7 +88,95 @@ 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)
+    }
+
+    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
   },
   init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) {
     scales <- list()

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")`
@@ -283,69 +294,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)
-    }
-
-    # 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) {
 

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

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")`
@@ -246,42 +255,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)
-    }
-
-    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) {
 

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
   )
 }
 
@@ -280,6 +283,7 @@ Layer <- ggproto("Layer", NULL,
     } else {
       self$computed_mapping <- self$mapping
     }
+    attr(data, "layout") <- self$layout
 
     data
   },