Support quosures in facets specs

Author: lionel-

R/facet-.r

@@ -203,38 +203,151 @@ df.grid <- function(a, b) {
   ))
 }
 
+# A facets spec is a list of facets. A grid facetting needs two facets
+# while a wrap facetting flattens all dimensions and thus accepts any
+# number of facets.
+#
+# A facets is a list of grouping variables. They are typically
+# supplied as variable names but can be expressions.
+#
+# as_facets() is complex due to historical baggage but its main
+# purpose is to create a facets spec from a formula: a + b ~ c + d
+# creates a facets list with two components, each of which bundles two
+# facetting variables.
+
+as_facets_spec <- function(x) {
+  if (inherits(x, "mapping")) {
+    stop("todo mapping")
+  }
+
+  # This needs to happen early because we might get a formula.
+  # facet_grid() directly converted strings to a formula while
+  # facet_wrap() called as.quoted(). Hence this is a little more
+  # complicated for backward compatibility.
+  if (rlang::is_string(x)) {
+    x <- plyr::as.quoted(x)
+    if (rlang::is_formula(x[[1]])) {
+      x <- x[[1]]
+    }
+  }
+
+  # At this level formulas are coerced to lists of lists for backward
+  # compatibility with facet_grid(). The LHS and RHS are treated as
+  # distinct facet dimensions and `+` defines multiple facet variables
+  # inside each dimension.
+  if (rlang::is_formula(x)) {
+    return(f_as_facets_spec(x))
+  }
+
+  # For backward-compatibility with facet_wrap()
+  if (!rlang::is_bare_list(x)) {
+    x <- plyr::as.quoted(x)
+    attributes(x) <- NULL
+  }
+
+  # If we have a list there are two possibilities. We may already have
+  # a proper facet spec structure. Otherwise we coerce each element
+  # with plyr::as.quoted() for backward compatibility with facet_grid().
+  if (is.list(x)) {
+    x <- lapply(x, as_facets)
+  }
+
+  if (sum(vapply(x, length, integer(1))) == 0L) {
+    stop("Must specify at least one variable to facet by", call. = FALSE)
+  }
+
+  x
+}
+
+f_as_facets_spec <- function(f) {
+  lhs <- function(x) if (length(x) == 2) NULL else x[-3]
+  rhs <- function(x) if (length(x) == 2) x else x[-2]
+
+  rows <- f_as_facets(lhs(f))
+  cols <- f_as_facets(rhs(f))
+
+  if (length(rows) + length(cols) == 0) {
+    stop("Must specify at least one variable to facet by", call. = FALSE)
+  }
+
+  if (length(rows)) {
+    list(rows, cols)
+  } else {
+    list(cols)
+  }
+}
+
+
+as_facets <- function(x) {
+  if (is_facets(x)) {
+    return(x)
+  }
+
+  if (rlang::is_formula(x)) {
+    # Use different formula method because plyr's does not handle the
+    # environment correctly.
+    f_as_facets(x)
+  } else {
+    vars <- plyr::as.quoted(x)
+    vars <- lapply(vars, rlang::new_quosure, env = globalenv())
+    rlang::quos_auto_name(vars)
+  }
+}
+f_as_facets <- function(f) {
+  if (is.null(f)) {
+    return(list())
+  }
+
+  env <- rlang::f_env(f) %||% globalenv()
+
+  # as.quoted() handles `+` specifications
+  vars <- plyr::as.quoted(f)
+
+  # `.` in formulas is ignored
+  vars <- discard_dots(vars)
+
+  vars <- lapply(vars, rlang::new_quosure, env)
+  rlang::quos_auto_name(vars)
+}
+discard_dots <- function(x) {
+  x[!vapply(x, identical, logical(1), as.name("."))]
+}
+
+is_facets <- function(x) {
+  if (!is.list(x)) {
+    return(FALSE)
+  }
+  if (!length(x)) {
+    return(FALSE)
+  }
+  all(vapply(x, rlang::is_quosure, logical(1)))
+}
+
+
 # When evaluating variables in a facet specification, we evaluate bare
 # variables and expressions slightly differently. Bare variables should
 # always succeed, even if the variable doesn't exist in the data frame:
 # that makes it possible to repeat data across multiple factors. But
 # when evaluating an expression, you want to see any errors. That does
 # mean you can't have background data when faceting by an expression,
 # but that seems like a reasonable tradeoff.
-eval_facet_vars <- function(vars, data, env = emptyenv()) {
-  nms <- names(vars)
-  out <- list()
-
-  for (i in seq_along(vars)) {
-    out[[ nms[[i]] ]] <- eval_facet_var(vars[[i]], data, env = env)
-  }
-
-  tibble::as_tibble(out)
+eval_facets <- function(facets, data, env = globalenv()) {
+  vars <- compact(lapply(facets, eval_facet, data, env = env))
+  tibble::as_tibble(vars)
 }
+eval_facet <- function(facet, data, env = emptyenv()) {
+  if (rlang::quo_is_symbol(facet)) {
+    facet <- as.character(rlang::quo_get_expr(facet))
 
-eval_facet_var <- function(var, data, env = emptyenv()) {
-  if (is.name(var)) {
-    var <- as.character(var)
-    if (var %in% names(data)) {
-      data[[var]]
+    if (facet %in% names(data)) {
+      out <- data[[facet]]
     } else {
-      NULL
+      out <- NULL
     }
-  } else if (is.call(var)) {
-    eval(var, envir = data, enclos = env)
-  } else {
-    stop("Must use either variable name or expression when faceting",
-      call. = FALSE)
+    return(out)
   }
+
+  rlang::eval_tidy(facet, data, env)
 }
 
 layout_null <- function() {
@@ -325,7 +438,7 @@ combine_vars <- function(data, env = emptyenv(), vars = NULL, drop = TRUE) {
   if (length(vars) == 0) return(data.frame())
 
   # For each layer, compute the facet values
-  values <- compact(plyr::llply(data, eval_facet_vars, vars = vars, env = env))
+  values <- compact(plyr::llply(data, eval_facets, facets = vars, env = env))
 
   # Form the base data frame which contains all combinations of faceting
   # variables that appear in the data

R/facet-grid-.r

@@ -146,26 +146,21 @@ facet_grid <- function(facets, margins = FALSE, scales = "fixed", space = "fixed
     stop("switch must be either 'both', 'x', or 'y'", call. = FALSE)
   }
 
-  # Facets can either be a formula, a string, or a list of things to be
-  # convert to quoted
-  if (is.character(facets)) {
-    facets <- stats::as.formula(facets)
-  }
-  if (is.formula(facets)) {
-    lhs <- function(x) if (length(x) == 2) NULL else x[-3]
-    rhs <- function(x) if (length(x) == 2) x else x[-2]
-
-    rows <- as.quoted(lhs(facets))
-    rows <- rows[!sapply(rows, identical, as.name("."))]
-    cols <- as.quoted(rhs(facets))
-    cols <- cols[!sapply(cols, identical, as.name("."))]
+  facets <- as_facets_spec(facets)
+
+  n <- length(facets)
+  if (!n) {
+    stop("FIXME: Internal error grid?")
   }
-  if (is.list(facets)) {
-    rows <- as.quoted(facets[[1]])
-    cols <- as.quoted(facets[[2]])
+  if (n > 2L) {
+    stop("A grid facet specification can't have more than two dimensions", call. = FALSE)
   }
-  if (length(rows) + length(cols) == 0) {
-    stop("Must specify at least one variable to facet by", call. = FALSE)
+  if (n == 1L) {
+    rows <- list()
+    cols <- facets[[1]]
+  } else {
+    rows <- facets[[1]]
+    cols <- facets[[2]]
   }
 
   # Check for deprecated labellers
@@ -187,8 +182,8 @@ FacetGrid <- ggproto("FacetGrid", Facet,
   shrink = TRUE,
 
   compute_layout = function(data, params) {
-    rows <- as.quoted(params$rows)
-    cols <- as.quoted(params$cols)
+    rows <- params$rows
+    cols <- params$cols
 
     dups <- intersect(names(rows), names(cols))
     if (length(dups) > 0) {
@@ -234,16 +229,16 @@ FacetGrid <- ggproto("FacetGrid", Facet,
       return(cbind(data, PANEL = integer(0)))
     }
 
-    rows <- as.quoted(params$rows)
-    cols <- as.quoted(params$cols)
+    rows <- params$rows
+    cols <- params$cols
     vars <- c(names(rows), names(cols))
 
     # Compute faceting values and add margins
     margin_vars <- list(intersect(names(rows), names(data)),
       intersect(names(cols), names(data)))
     data <- reshape2::add_margins(data, margin_vars, params$margins)
 
-    facet_vals <- eval_facet_vars(c(rows, cols), data, params$plot_env)
+    facet_vals <- eval_facets(c(rows, cols), data, params$plot_env)
 
     # If any faceting variables are missing, add them in by
     # duplicating the data
@@ -405,7 +400,7 @@ FacetGrid <- ggproto("FacetGrid", Facet,
     panel_table
   },
   vars = function(self) {
-    vapply(c(self$params$rows, self$params$cols), as.character, character(1))
+    names(c(self$params$rows, self$params$cols))
   }
 )
 

R/facet-wrap.r

@@ -105,13 +105,22 @@ facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed",
   # Check for deprecated labellers
   labeller <- check_labeller(labeller)
 
+  # Flatten all facets dimensions into a single one
+  facets <- rlang::flatten(as_facets_spec(facets))
+
   ggproto(NULL, FacetWrap,
     shrink = shrink,
-    params = list(facets = as.quoted(facets), free = free,
-    as.table = as.table, strip.position = strip.position,
-    drop = drop, ncol = ncol, nrow = nrow,
-    labeller = labeller,
-    dir = dir)
+    params = list(
+      facets = facets,
+      free = free,
+      as.table = as.table,
+      strip.position = strip.position,
+      drop = drop,
+      ncol = ncol,
+      nrow = nrow,
+      labeller = labeller,
+      dir = dir
+    )
   )
 }
 
@@ -123,8 +132,10 @@ FacetWrap <- ggproto("FacetWrap", Facet,
   shrink = TRUE,
 
   compute_layout = function(data, params) {
-    vars <- as.quoted(params$facets)
-    if (length(vars) == 0) return(layout_null())
+    vars <- params$facets
+    if (length(vars) == 0) {
+      return(layout_null())
+    }
 
     base <- plyr::unrowname(
       combine_vars(data, params$plot_env, vars, drop = params$drop)
@@ -162,9 +173,9 @@ FacetWrap <- ggproto("FacetWrap", Facet,
     if (empty(data)) {
       return(cbind(data, PANEL = integer(0)))
     }
-    vars <- as.quoted(params$facets)
+    vars <- params$facets
 
-    facet_vals <- eval_facet_vars(vars, data, params$plot_env)
+    facet_vals <- eval_facets(vars, data, params$plot_env)
     facet_vals[] <- lapply(facet_vals[], as.factor)
 
     missing_facets <- setdiff(names(vars), names(facet_vals))
@@ -338,7 +349,7 @@ FacetWrap <- ggproto("FacetWrap", Facet,
     panel_table
   },
   vars = function(self) {
-    vapply(self$params$facets, as.character, character(1))
+    names(self$params$facets)
   }
 )
 

tests/testthat/test-facet-.r

@@ -1,5 +1,46 @@
 context("Facetting")
 
+quo <- rlang::quo
+quoted_obj <- structure(list(), class = "quoted_obj")
+as.quoted.quoted_obj <- function(...) plyr::as.quoted(quote(dispatched), globalenv())
+assign("as.quoted.quoted_obj", as.quoted.quoted_obj, envir = globalenv())
+
+test_that("as_facets_spec() coerces formulas", {
+  expect_identical(as_facets_spec(~foo), list(list(foo = quo(foo))))
+  expect_identical(as_facets_spec(~foo + bar), list(list(foo = quo(foo), bar = quo(bar))))
+
+  expect_identical(as_facets_spec(foo ~ bar), list(list(foo = quo(foo)), list(bar = quo(bar))))
+
+  exp <- list(list(foo = quo(foo), bar = quo(bar)), list(baz = quo(baz), bam = quo(bam)))
+  expect_identical(as_facets_spec(foo + bar ~ baz + bam), exp)
+
+  exp <- list(list(`foo()`= quo(foo()), `bar()` = quo(bar())), list(`baz()` = quo(baz()), `bam()` = quo(bam())))
+  expect_identical(as_facets_spec(foo() + bar() ~ baz() + bam()), exp)
+})
+
+test_that("as_facets_spec() coerces strings containing formulas", {
+  expect_identical(as_facets_spec("foo ~ bar"), as_facets_spec(local(foo ~ bar, globalenv())))
+})
+
+test_that("as_facets_spec() coerces character vectors", {
+  expect_identical(as_facets_spec("foo"), as_facets_spec(local(~foo, globalenv())))
+  expect_identical(as_facets_spec(c("foo", "bar")), as_facets_spec(local(foo ~ bar, globalenv())))
+})
+
+test_that("as_facets_spec() coerces lists", {
+  out <- as_facets_spec(list(quote(foo), c("foo", "bar"), NULL, quoted_obj))
+  exp <- c(as_facets_spec(quote(foo)), list(rlang::flatten(as_facets_spec(c("foo", "bar")))), list(list()), as_facets_spec(quoted_obj))
+  expect_identical(out, exp)
+})
+
+test_that("as_facets_spec() errors with empty specs", {
+  expect_error(as_facets_spec(list()), "at least one variable to facet by")
+  expect_error(as_facets_spec(. ~ .), "at least one variable to facet by")
+  expect_error(as_facets_spec(list(. ~ .)), "at least one variable to facet by")
+  expect_error(as_facets_spec(list(NULL)), "at least one variable to facet by")
+})
+
+
 df <- data.frame(x = 1:3, y = 3:1, z = letters[1:3])
 
 test_that("facets split up the data", {