Support drop in facet_grid and facet_wrap.

Fixes #163

Author: hadley

R/facet-grid-.r

@@ -24,6 +24,9 @@
 #' @param shrink If \code{TRUE}, will shrink scales to fit output of
 #'   statistics, not raw data. If \code{FALSE}, will be range of raw data
 #'   before statistical summary.
+#' @param drop If \code{TRUE}, the default, all factor levels not used in the
+#'   data will automatically be dropped. If \code{FALSE}, all factor levels
+#'   will be shown, regardless of whether or not they appear in the data.
 #' @export
 #' @examples 
 #' # faceting displays subsets of the data in different panels
@@ -122,7 +125,7 @@
 #' p <- qplot(wt, mpg, data = mtcars)
 #' p + facet_grid(~ vs, labeller = label_bquote(alpha ^ .(x)))
 #' p + facet_grid(~ vs, labeller = label_bquote(.(x) ^ .(x)))
-facet_grid <- function(facets, margins = FALSE, scales = "fixed", space = "fixed", shrink = TRUE, labeller = "label_value", as.table = TRUE) {
+facet_grid <- function(facets, margins = FALSE, scales = "fixed", space = "fixed", shrink = TRUE, labeller = "label_value", as.table = TRUE, drop = TRUE) {
   scales <- match.arg(scales, c("fixed", "free_x", "free_y", "free"))
   free <- list(
     x = any(scales %in% c("free_x", "free")),
@@ -152,18 +155,19 @@ facet_grid <- function(facets, margins = FALSE, scales = "fixed", space = "fixed
   facet(
     rows = rows, cols = cols, margins = margins, shrink = shrink,
     free = free, space_is_free = (space == "free"),
-    labeller = labeller, as.table = as.table,
+    labeller = labeller, as.table = as.table, drop = drop,
     subclass = "grid"
   )
 }
 
 #' @S3method facet_train_layout grid
 facet_train_layout.grid <- function(facet, data) { 
-  layout <- layout_grid(data, facet$rows, facet$cols, facet$margins)
-
+  layout <- layout_grid(data, facet$rows, facet$cols, facet$margins,
+    facet$drop)
+    
   # Relax constraints, if necessary
-  layout$SCALE_X <- if (facet$free$x) layout$COL else 1
-  layout$SCALE_Y <- if (facet$free$y) layout$ROW else 1
+  layout$SCALE_X <- if (facet$free$x) layout$COL else 1L
+  layout$SCALE_Y <- if (facet$free$y) layout$ROW else 1L
 
   layout
 }

R/facet-layout.r

@@ -6,13 +6,14 @@
 # @return a data frame with columns \code{PANEL}, \code{ROW} and \code{COL},
 #   that match the facetting variable values up with their position in the 
 #   grid
-layout_grid <- function(data, rows = NULL, cols = NULL, margins = NULL) {
+layout_grid <- function(data, rows = NULL, cols = NULL, margins = NULL, drop = TRUE) {
   if (length(rows) == 0 && length(cols) == 0) return(layout_null())
   rows <- as.quoted(rows)
   cols <- as.quoted(cols)
+
 
-  base_rows <- layout_base(data, rows)
-  base_cols <- layout_base(data, cols)
+  base_rows <- layout_base(data, rows, drop = drop)
+  base_cols <- layout_base(data, cols, drop = drop)
   base <- df.grid(base_rows, base_cols)
 
   # Add margins
@@ -24,8 +25,8 @@ layout_grid <- function(data, rows = NULL, cols = NULL, margins = NULL) {
   panel <- id(base, drop = TRUE)
   panel <- factor(panel, levels = seq_len(attr(panel, "n")))
 
-  rows <- if (is.null(names(rows))) 1 else id(base[names(rows)], drop = TRUE)
-  cols <- if (is.null(names(cols))) 1 else id(base[names(cols)], drop = TRUE)
+  rows <- if (is.null(names(rows))) 1L else id(base[names(rows)], drop = TRUE)
+  cols <- if (is.null(names(cols))) 1L else id(base[names(cols)], drop = TRUE)
 
   panels <- data.frame(PANEL = panel, ROW = rows, COL = cols, base)
   arrange(panels, PANEL)
@@ -35,28 +36,26 @@ layout_grid <- function(data, rows = NULL, cols = NULL, margins = NULL) {
 #
 # @params drop should missing combinations be excluded from the plot?
 # @keywords internal
-layout_wrap <- function(data, vars = NULL, nrow = NULL, ncol = NULL, as.table = TRUE) {
+layout_wrap <- function(data, vars = NULL, nrow = NULL, ncol = NULL, as.table = TRUE, drop = TRUE) {
   vars <- as.quoted(vars)
   if (length(vars) == 0) return(layout_null())
 
-  base <- unrowname(layout_base(data, vars))
+  base <- unrowname(layout_base(data, vars, drop = drop))
 
   id <- id(base, drop = TRUE)
   n <- attr(id, "n")
 
   dims <- wrap_dims(n, nrow, ncol)
-  
   layout <- data.frame(PANEL = factor(id, levels = seq_len(n)))
 
   if (as.table) {
-    layout$ROW <- (as.integer(id) - 1L) %/% dims[2] + 1L
+    layout$ROW <- as.integer((id - 1L) %/% dims[2] + 1L)
   } else {
-    layout$ROW <- dims[1] - (as.integer(id) - 1L) %/% dims[2]
+    layout$ROW <- as.integer(dims[1] - (id - 1L) %/% dims[2])
   }
-  layout$COL <- (as.integer(id) - 1L) %% dims[2] + 1L
+  layout$COL <- as.integer((id - 1L) %% dims[2] + 1L)
 
-  layout <- cbind(layout, base)  
-  layout[order(layout$PANEL), ]
+  cbind(layout, unrowname(base))
 }
 
 layout_null <- function(data) { 
@@ -68,7 +67,7 @@ layout_null <- function(data) {
 #
 # @params data list of data frames (one for each layer)
 # @keywords internal
-layout_base <- function(data, vars = NULL) {
+layout_base <- function(data, vars = NULL, drop = TRUE) {
   if (length(vars) == 0) return(data.frame())
 
   # For each layer, compute the facet values
@@ -80,20 +79,44 @@ layout_base <- function(data, vars = NULL) {
   if (!any(has_all)) {
     stop("At least one layer must contain all variables used for facetting")
   }
-  base <- unique(ldply(values[has_all]))
+  
+  base <- unique(ldply(values[has_all]))    
+  if (!drop) {
+    base <- unique_combs(base)
+  }
 
   # Systematically add on missing combinations
   for (value in values[!has_all]) {
     if (empty(value)) next;
 
     old <- base[setdiff(names(base), names(value))]
     new <- unique(value[intersect(names(base), names(value))])  
+    if (drop) {
+      new <- unique_combs(new)
+    }
 
     base <- rbind(base, df.grid(old, new))
   }
   base
 }
 
+ulevels <- function(x) {
+  if (is.factor(x)) {
+    x <- addNA(x, TRUE)
+    factor(levels(x), levels(x), exclude = NULL)
+  } else {
+    sort(unique(x))
+  }
+}
+
+unique_combs <- function(df) {
+  if (length(df) == 0) return()
+  
+  unique_values <- llply(df, ulevels)
+  rev(expand.grid(rev(unique_values), stringsAsFactors = FALSE, 
+    KEEP.OUT.ATTRS = TRUE))
+}
+
 df.grid <- function(a, b) {
   if (nrow(a) == 0) return(b)
   if (nrow(b) == 0) return(a)
@@ -102,11 +125,10 @@ df.grid <- function(a, b) {
     i_a = seq_len(nrow(a)), 
     i_b = seq_len(nrow(b))
   )
-  both <- cbind(
+  unrowname(cbind(
     a[indexes$i_a, , drop = FALSE], 
     b[indexes$i_b, , drop = FALSE]
-  )
-  
+  ))
 }
 
 quoted_df <- function(data, vars) {

R/facet-locate.r

@@ -36,6 +36,7 @@ locate_grid <- function(data, panels, rows = NULL, cols = NULL, margins = FALSE)
     data$PANEL <- 1
   } else {
     facet_vals[] <- lapply(facet_vals[], as.factor)
+    facet_vals[] <- lapply(facet_vals[], addNA, ifany = TRUE)
     keys <- join.keys(facet_vals, panels, by = vars)
 
     data$PANEL <- panels$PANEL[match(keys$x, keys$y)]

R/facet-wrap.r

@@ -50,7 +50,7 @@
 #'   facet_wrap(~ cyl)
 #' p + geom_point(data = transform(cyl6, cyl = NULL), colour = "red") + 
 #'   facet_wrap(~ cyl)
-facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed", shrink = TRUE, as.table = TRUE) {
+facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed", shrink = TRUE, as.table = TRUE, drop = TRUE) {
   scales <- match.arg(scales, c("fixed", "free_x", "free_y", "free"))
   free <- list(
     x = any(scales %in% c("free_x", "free")),
@@ -68,14 +68,14 @@ facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed", shrin
 #' @S3method facet_train_layout wrap
 facet_train_layout.wrap <- function(facet, data) { 
   panels <- layout_wrap(data, facet$facets, facet$nrow, facet$ncol,
-     facet$as.table)
+     facet$as.table, facet$drop)
 
   n <- nrow(panels)
   nrow <- max(panels$ROW)
 
   # Add scale identification
-  panels$SCALE_X <- if (facet$free$x) seq_len(n) else 1
-  panels$SCALE_Y <- if (facet$free$y) seq_len(n) else 1
+  panels$SCALE_X <- if (facet$free$x) seq_len(n) else 1L
+  panels$SCALE_Y <- if (facet$free$y) seq_len(n) else 1L
 
   # Figure out where axes should go
   panels$AXIS_X <- if (facet$free$x) TRUE else panels$ROW == nrow

R/panel.r

@@ -27,7 +27,6 @@ new_panel <- function() {
 # @return an updated panel object
 train_layout <- function(panel, facet, data, plot_data) {
   layout <- facet_train_layout(facet, c(data, list(plot_data)))
-
   panel$layout <- layout
   panel$shrink <- facet$shrink
 
@@ -141,6 +140,7 @@ scale_apply <- function(data, vars, f, scale_id, scales) {
   if (length(vars) == 0) return()
 
   n <- length(scales)
+  if (any(is.na(scale_id))) stop()
   scale_index <- plyr:::split_indices(seq_len(nrow(data)), scale_id, n)
 
   lapply(vars, function(var) {

inst/tests/test-facet-layout.r

@@ -78,4 +78,62 @@ test_that("wrap: as.table reverses rows", {
   two <- layout_wrap(list(a), "a", nrow = 1, as.table = FALSE)
   expect_that(two$ROW, equals(c(1, 1)))
 
+})
+
+# Drop behaviour -------------------------------------------------------------
+
+a2 <- data.frame(
+  a = factor(1:3, levels = 1:4),
+  b = factor(1:3, levels = 4:1)
+)
+
+test_that("layout_wrap: drop = FALSE preserves unused levels", {
+  wrap_a <- layout_wrap(list(a2), "a", drop = FALSE)
+  expect_equal(nrow(wrap_a), 4)
+  expect_equal(as.character(wrap_a$a), as.character(1:4))
+  
+  wrap_b <- layout_wrap(list(a2), "b", drop = FALSE)
+  expect_equal(nrow(wrap_b), 4)
+  expect_equal(as.character(wrap_b$b), as.character(4:1))
+  
+})
+
+test_that("layout_grid: drop = FALSE preserves unused levels", {
+  grid_a <- layout_grid(list(a2), "a", drop = FALSE)
+  expect_equal(nrow(grid_a), 4)
+  expect_equal(as.character(grid_a$a), as.character(1:4))
+  
+  grid_b <- layout_grid(list(a2), "b", drop = FALSE)
+  expect_equal(nrow(grid_b), 4)
+  expect_equal(as.character(grid_b$b), as.character(4:1))
+
+  grid_ab <- layout_grid(list(a2), "a", "b", drop = FALSE)
+  expect_equal(nrow(grid_ab), 16)
+  expect_equal(as.character(grid_ab$a), as.character(rep(1:4, each = 4)))
+  expect_equal(as.character(grid_ab$b), as.character(rep(4:1, 4)))
+  
+})
+
+# Missing behaviour ----------------------------------------------------------
+
+a3 <- data.frame(
+  a = c(1:3, NA),
+  b = factor(c(1:3, NA)),
+  c = factor(c(1:3, NA), exclude = NULL)
+)
+
+test_that("missing values get a panel", {
+  wrap_a <- layout_wrap(list(a3), "a")
+  wrap_b <- layout_wrap(list(a3), "b")
+  wrap_c <- layout_wrap(list(a3), "c")
+  grid_a <- layout_grid(list(a3), "a")
+  grid_b <- layout_grid(list(a3), "b")
+  grid_c <- layout_grid(list(a3), "c")
+  
+  expect_equal(nrow(wrap_a), 4)
+  expect_equal(nrow(wrap_b), 4)
+  expect_equal(nrow(wrap_c), 4)
+  expect_equal(nrow(grid_a), 4)
+  expect_equal(nrow(grid_b), 4)
+  expect_equal(nrow(grid_c), 4)
 })

inst/tests/test-facet-locate.r

@@ -58,4 +58,33 @@ test_that("wrap: missing facet columns are duplicated", {
   expect_that(nrow(loc_c), equals(4))
   expect_that(loc_c$PANEL, equals(factor(1:4)))
 
+})
+
+# Missing behaviour ----------------------------------------------------------
+
+a3 <- data.frame(
+#  a = c(1:3, NA), Not currently supported
+  b = factor(c(1:3, NA)),
+  c = factor(c(1:3, NA), exclude = NULL)
+)
+
+test_that("wrap: missing values located correctly", {
+  panel_b <- layout_wrap(list(a3), "b", ncol = 1)
+  loc_b <- locate_wrap(data.frame(b = NA), panel_b, "b")
+  expect_equal(as.character(loc_b$PANEL), "4")
+
+  panel_c <- layout_wrap(list(a3), "c", ncol = 1)
+  loc_c <- locate_wrap(data.frame(c = NA), panel_c, "c")
+  expect_equal(as.character(loc_c$PANEL), "4")
+  
+})
+
+test_that("grid: missing values located correctly", {
+  panel_b <- layout_grid(list(a3), "b")
+  loc_b <- locate_grid(data.frame(b = NA), panel_b, "b")
+  expect_equal(as.character(loc_b$PANEL), "4")
+
+  panel_c <- layout_grid(list(a3), "c")
+  loc_c <- locate_grid(data.frame(c = NA), panel_c, "c")
+  expect_equal(as.character(loc_c$PANEL), "4")
 })

man/facet_grid.Rd

@@ -4,7 +4,7 @@
 \usage{
   facet_grid(facets, margins = FALSE, scales = "fixed",
     space = "fixed", shrink = TRUE,
-    labeller = "label_value", as.table = TRUE)
+    labeller = "label_value", as.table = TRUE, drop = TRUE)
 }
 \arguments{
   \item{facets}{a formula with the rows (of the tabular
@@ -44,6 +44,12 @@
   \item{shrink}{If \code{TRUE}, will shrink scales to fit
   output of statistics, not raw data. If \code{FALSE}, will
   be range of raw data before statistical summary.}
+
+  \item{drop}{If \code{TRUE}, the default, all factor
+  levels not used in the data will automatically be
+  dropped. If \code{FALSE}, all factor levels will be
+  shown, regardless of whether or not they appear in the
+  data.}
 }
 \description{
   Lay out panels in a grid.

man/facet_wrap.Rd

@@ -3,7 +3,8 @@
 \title{Wrap a 1d ribbon of panels into 2d.}
 \usage{
   facet_wrap(facets, nrow = NULL, ncol = NULL,
-    scales = "fixed", shrink = TRUE, as.table = TRUE)
+    scales = "fixed", shrink = TRUE, as.table = TRUE,
+    drop = TRUE)
 }
 \arguments{
   \item{nrow}{number of rows}
@@ -24,6 +25,12 @@
   are laid out like a table with highest values at the
   bottom-right. If \code{FALSE}, the facet are laid out
   like a plot with the highest value at the top-right.}
+
+  \item{drop}{If \code{TRUE}, the default, all factor
+  levels not used in the data will automatically be
+  dropped. If \code{FALSE}, all factor levels will be
+  shown, regardless of whether or not they appear in the
+  data.}
 }
 \description{
   Wrap a 1d ribbon of panels into 2d.