More sorting options for facet_wrap() (#5855)

* resolve `dir`/`as.table`

* new wrap layouts

* add tests

* add news bullet

* skip `as.table` option in vignette

* add example

Author: teunbrand

NEWS.md

@@ -1,5 +1,7 @@
 # ggplot2 (development version)
 
+* `facet_wrap()` has new options for the `dir` argument to more precisely
+  control panel directions (@teunbrand, #5212)
 * Prevented `facet_wrap(..., drop = FALSE)` from throwing spurious errors when
   a character facetting variable contained `NA`s (@teunbrand, #5485).
 * When facets coerce the faceting variables to factors, the 'ordered' class

R/facet-wrap.R

@@ -23,7 +23,12 @@ NULL
 #'   either of the four sides by setting \code{strip.position = c("top",
 #'   "bottom", "left", "right")}
 #' @param dir Direction: either `"h"` for horizontal, the default, or `"v"`,
-#'   for vertical.
+#'   for vertical. When `"h"` or `"v"` will be combined with `as.table` to
+#'   set final layout. Alternatively, a combination of `"t"` (top) or
+#'   `"b"` (bottom) with `"l"` (left) or `"r"` (right) to set a layout directly.
+#'   These two letters give the starting position and the first letter gives
+#'   the growing direction. For example `"rt"` will place the first panel in
+#'   the top-right and starts filling in panels right-to-left.
 #' @param axes Determines which axes will be drawn in case of fixed scales.
 #'   When `"margins"` (default), axes will be drawn at the exterior margins.
 #'   `"all_x"` and `"all_y"` will draw the respective axes at the interior
@@ -95,13 +100,29 @@ NULL
 #'   facet_wrap(vars(variable), scales = "free_y", nrow = 2, strip.position = "top") +
 #'   theme(strip.background = element_blank(), strip.placement = "outside")
 #' }
+#'
+#' # The two letters determine the starting position, so 'tr' starts
+#' # in the top-right.
+#' # The first letter determines direction, so 'tr' fills top-to-bottom.
+#' # `dir = "tr"` is equivalent to `dir = "v", as.table = FALSE`
+#' ggplot(mpg, aes(displ, hwy)) +
+#'   geom_point() +
+#'   facet_wrap(vars(class), dir = "tr")
 facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed",
                        shrink = TRUE, labeller = "label_value", as.table = TRUE,
                        switch = deprecated(), drop = TRUE, dir = "h",
                        strip.position = 'top', axes = "margins",
                        axis.labels = "all") {
   scales <- arg_match0(scales %||% "fixed", c("fixed", "free_x", "free_y", "free"))
-  dir <- arg_match0(dir, c("h", "v"))
+  dir <- arg_match0(dir, c("h", "v", "lt", "tl", "lb", "bl", "rt", "tr", "rb", "br"))
+  if (nchar(dir) == 1) {
+    dir <- base::switch(
+      dir,
+      h = if (as.table) "lt" else "lb",
+      v = if (as.table) "tl" else "tr"
+    )
+  }
+
   free <- list(
     x = any(scales %in% c("free_x", "free")),
     y = any(scales %in% c("free_y", "free"))
@@ -149,7 +170,6 @@ facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed",
     params = list(
       facets = facets,
       free = free,
-      as.table = as.table,
       strip.position = strip.position,
       drop = drop,
       ncol = ncol,
@@ -189,21 +209,7 @@ FacetWrap <- ggproto("FacetWrap", Facet,
     n <- attr(id, "n")
 
     dims <- wrap_dims(n, params$nrow, params$ncol)
-    layout <- data_frame0(
-      PANEL = factor(id, levels = seq_len(n)),
-      ROW = if (params$as.table) {
-        as.integer((id - 1L) %/% dims[2] + 1L)
-      } else {
-        as.integer(dims[1] - (id - 1L) %/% dims[2])
-      },
-      COL = as.integer((id - 1L) %% dims[2] + 1L),
-      .size = length(id)
-    )
-
-    # For vertical direction, flip row and col
-    if (identical(params$dir, "v")) {
-      layout[c("ROW", "COL")] <- layout[c("COL", "ROW")]
-    }
+    layout <- wrap_layout(id, dims, params$dir)
 
     panels <- vec_cbind(layout, base)
     panels <- panels[order(panels$PANEL), , drop = FALSE]
@@ -576,3 +582,31 @@ measure_axes <- function(empty_idx, axis, margin = 1L, shift = 0) {
   cm[set_zero] <- 0
   unit(apply(cm, margin, max), "cm")
 }
+
+wrap_layout <- function(id, dims, dir) {
+  as.table <- TRUE
+  n <- attr(id, "n")
+
+  ROW <- switch(
+    dir,
+    lt = , rt = (id - 1L) %/% dims[2] + 1L,
+    tl = , tr = (id - 1L) %%  dims[1] + 1L,
+    lb = , rb = dims[1] - (id - 1L) %/% dims[2],
+    bl = , br = dims[1] - (id - 1L) %%  dims[1]
+  )
+
+  COL <- switch(
+    dir,
+    lt = , lb = (id - 1L) %% dims[2] + 1L,
+    tl = , bl = (id - 1L) %/% dims[1] + 1L,
+    rt = , rb = dims[2] - (id - 1L) %%  dims[2],
+    tr = , br = dims[2] - (id - 1L) %/% dims[1]
+  )
+
+  data_frame0(
+    PANEL = factor(id, levels = seq_len(n)),
+    ROW   = as.integer(ROW),
+    COL   = as.integer(COL),
+    .size = length(id)
+  )
+}

man/facet_wrap.Rd

@@ -32,6 +32,44 @@ test_that("grid: includes all combinations", {
   expect_equal(nrow(all), 4)
 })
 
+test_that("wrap: layout sorting is correct", {
+
+  dummy <- list(data_frame0(x = 1:5))
+
+  test <- panel_layout(facet_wrap(~x, dir = "lt"), dummy)
+  expect_equal(test$ROW, rep(c(1,2), c(3, 2)))
+  expect_equal(test$COL, c(1:3, 1:2))
+
+  test <- panel_layout(facet_wrap(~x, dir = "tl"), dummy)
+  expect_equal(test$ROW, c(1, 2, 1, 2, 1))
+  expect_equal(test$COL, c(1, 1, 2, 2, 3))
+
+  test <- panel_layout(facet_wrap(~x, dir = "lb"), dummy)
+  expect_equal(test$ROW, c(2, 2, 2, 1, 1))
+  expect_equal(test$COL, c(1, 2, 3, 1, 2))
+
+  test <- panel_layout(facet_wrap(~x, dir = "bl"), dummy)
+  expect_equal(test$ROW, c(2, 1, 2, 1, 2))
+  expect_equal(test$COL, c(1, 1, 2, 2, 3))
+
+  test <- panel_layout(facet_wrap(~x, dir = "rt"), dummy)
+  expect_equal(test$ROW, c(1, 1, 1, 2, 2))
+  expect_equal(test$COL, c(3, 2, 1, 3, 2))
+
+  test <- panel_layout(facet_wrap(~x, dir = "tr"), dummy)
+  expect_equal(test$ROW, c(1, 2, 1, 2, 1))
+  expect_equal(test$COL, c(3, 3, 2, 2, 1))
+
+  test <- panel_layout(facet_wrap(~x, dir = "rb"), dummy)
+  expect_equal(test$ROW, c(2, 2, 2, 1, 1))
+  expect_equal(test$COL, c(3, 2, 1, 3, 2))
+
+  test <- panel_layout(facet_wrap(~x, dir = "br"), dummy)
+  expect_equal(test$ROW, c(2, 1, 2, 1, 2))
+  expect_equal(test$COL, c(3, 3, 2, 2, 1))
+
+})
+
 test_that("wrap and grid are equivalent for 1d data", {
   rowg <- panel_layout(facet_grid(a~.), list(a))
   roww <- panel_layout(facet_wrap(~a, ncol = 1), list(a))

tests/testthat/test-facet-layout.R

@@ -1054,11 +1054,7 @@ FacetBootstrap <- ggproto("FacetBootstrap", FacetWrap,
     dims <- wrap_dims(params$n, params$nrow, params$ncol)
     layout <- data.frame(PANEL = factor(id))
 
-    if (params$as.table) {
-      layout$ROW <- as.integer((id - 1L) %/% dims[2] + 1L)
-    } else {
-      layout$ROW <- as.integer(dims[1] - (id - 1L) %/% dims[2])
-    }
+    layout$ROW <- as.integer((id - 1L) %/% dims[2] + 1L)
     layout$COL <- as.integer((id - 1L) %% dims[2] + 1L)
 
     layout <- layout[order(layout$PANEL), , drop = FALSE]