Layer parameter controlling facet layout (#6336)

* append layout attribute to layer data

* repeat data for fixed layout

* unify `Facet$map_data()` approaches

* put comments back in

* Implement keywords for fixing rows / columns

* use integers to select panels

* document the use of the `layout` argument

* add news bullet

* swap facet data mapping from method to standalone function

Author: teunbrand

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()` 

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
+}

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) {
 

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")`
@@ -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) {
 

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
   },