tests/testthat/test-facet-.R

In tidyverse/ggplot2: Create Elegant Data Visualisations Using the Grammar of Graphics

test_that("as_facets_list() coerces formulas", {
  expect_identical(as_facets_list(~foo), list(quos(), quos(foo = foo)))
  expect_identical(as_facets_list(~foo + bar), list(quos(), quos(foo = foo, bar = bar)))
  expect_identical(as_facets_list(foo ~ bar), list(quos(foo = foo), quos(bar = bar)))

  exp <- list(quos(foo = foo, bar = bar), quos(baz = baz, bam = bam))
  expect_identical(as_facets_list(foo + bar ~ baz + bam), exp)

  exp <- list(quos(`foo()`= foo(), `bar()` = bar()), quos(`baz()` = baz(), `bam()` = bam()))
  expect_identical(as_facets_list(foo() + bar() ~ baz() + bam()), exp)
})

test_that("as_facets_list() coerces strings containing formulas", {
  expect_identical(as_facets_list("foo ~ bar"), as_facets_list(local(foo ~ bar, globalenv())))
})

test_that("as_facets_list() coerces character vectors", {
  foo <- new_quosure(quote(foo), globalenv())
  bar <- new_quosure(quote(bar), globalenv())
  foobar <- as_quosures(list(foo, bar), named = TRUE)

  expect_identical(as_facets_list("foo"), list(foobar[1]))
  expect_identical(as_facets_list(c("foo", "bar")), list(foobar[1], foobar[2]))
  expect_identical(wrap_as_facets_list(c("foo", "bar")), foobar)
})

test_that("as_facets_list() coerces lists", {
  out <- as_facets_list(list(
    quote(foo),
    c("foo", "bar"),
    NULL
  ))
  exp <- c(
    as_facets_list(quote(foo)),
    list(do.call(base::`c`, as_facets_list(c("foo", "bar")))),
    list(quos_list())
  )
  expect_identical(out, exp)
})

test_that("as_facets_list() coerces quosures objectss", {
  expect_identical(as_facets_list(vars(foo)), list(quos(foo = foo)))
})

test_that("facets reject aes()", {
  expect_error(facet_wrap(aes(foo)), "Please use `vars()` to supply facet variables", fixed = TRUE)
  expect_error(facet_grid(aes(foo)), "Please use `vars()` to supply facet variables", fixed = TRUE)
})

test_that("wrap_as_facets_list() returns a quosures object with compacted", {
  expect_identical(wrap_as_facets_list(vars(foo)), quos(foo = foo))
  expect_identical(wrap_as_facets_list(~foo + bar), quos(foo = foo, bar = bar))

  f <- function(x) {
    expect_identical(wrap_as_facets_list(vars(foo, {{ x }}, bar)), quos(foo = foo, bar = bar))
  }

  f(NULL)
  f()
})

test_that("grid_as_facets_list() returns a list of quosures objects with compacted", {
  expect_identical(grid_as_facets_list(vars(foo), NULL), list(rows = quos(foo = foo), cols = quos()))
  expect_identical(grid_as_facets_list(~foo, NULL), list(rows = quos(), cols = quos(foo = foo)))

  f <- function(x) {
    expect_identical(grid_as_facets_list(vars(foo, {{ x }}, bar), NULL), list(rows = quos(foo = foo, bar = bar), cols = quos()))
  }

  f(NULL)
  f()
})

test_that("wrap_as_facets_list() and grid_as_facets_list() accept empty specs", {
  expect_identical(wrap_as_facets_list(NULL), quos())
  expect_identical(wrap_as_facets_list(list()), quos())
  expect_identical(wrap_as_facets_list(. ~ .), quos())
  expect_identical(wrap_as_facets_list(list(. ~ .)), quos())
  expect_identical(wrap_as_facets_list(list(NULL)), quos())

  expect_identical(grid_as_facets_list(list(), NULL), list(rows = quos(), cols = quos()))
  expect_identical(grid_as_facets_list(. ~ ., NULL), list(rows = quos(), cols = quos()))
  expect_identical(grid_as_facets_list(list(. ~ .), NULL), list(rows = quos(), cols = quos()))
  expect_identical(grid_as_facets_list(list(NULL), NULL), list(rows = quos(), cols = quos()))
})

test_that("facets split up the data", {
  df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3])
  p <- ggplot(df, aes(x, y)) + geom_point()

  l1 <- p + facet_wrap(~z)
  l2 <- p + facet_grid(. ~ z)
  l3 <- p + facet_grid(z ~ .)

  d1 <- layer_data(l1)
  d2 <- layer_data(l2)
  d3 <- layer_data(l3)

  expect_equal(d1, d2)
  expect_equal(d1, d3)
  expect_equal(d1$PANEL, factor(1:3))

  # Handle empty layers
  p_empty <- ggplot() + geom_point(aes(x, y), df) + geom_line()
  l4 <- p_empty + facet_wrap(~z)
  l5 <- p_empty + facet_grid(. ~ z)

  d4 <- layer_data(l4)
  d5 <- layer_data(l5)

  expect_equal(d1, d4)
  expect_equal(d1, d5)
})


test_that("facet_wrap() accepts vars()", {
  df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3])
  p <- ggplot(df, aes(x, y)) + geom_point()

  p1 <- p + facet_wrap(~z)
  p2 <- p + facet_wrap(vars(Z = z), labeller = label_both)

  expect_identical(layer_data(p1), layer_data(p2))
})

test_that("facet_grid() accepts vars()", {
  grid <- facet_grid(vars(a = foo))
  expect_identical(grid$params$rows, quos(a = foo))

  grid <- facet_grid(vars(a = foo), vars(b = bar))
  expect_identical(grid$params$rows, quos(a = foo))
  expect_identical(grid$params$cols, quos(b = bar))

  grid <- facet_grid(vars(foo), vars(bar))
  expect_identical(grid$params$rows, quos(foo = foo))
  expect_identical(grid$params$cols, quos(bar = bar))

  expect_equal(facet_grid(vars(am, vs))$params, facet_grid(am + vs ~ .)$params)
  expect_equal(facet_grid(vars(am, vs), vars(cyl))$params, facet_grid(am + vs ~ cyl)$params)
  expect_equal(facet_grid(NULL, vars(cyl))$params, facet_grid(. ~ cyl)$params)
  expect_equal(facet_grid(vars(am, vs), TRUE)$params, facet_grid(am + vs ~ ., margins = TRUE)$params)
})

test_that("facet_grid() fails if passed both a formula and a vars()", {
  expect_snapshot_error(facet_grid(~foo, vars()))
})

test_that("can't pass formulas to `cols`", {
  expect_snapshot_error(facet_grid(NULL, ~foo))
})

test_that("can still pass `margins` as second argument", {
  grid <- facet_grid(~foo, TRUE)
  expect_true(grid$params$margins)
})

test_that("vars() accepts optional names", {
  wrap <- facet_wrap(vars(A = a, b))
  expect_named(wrap$params$facets, c("A", "b"))
})

test_that("facet_wrap()/facet_grid() compact the facet spec, and accept empty spec", {
  df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3])
  p <- ggplot(df, aes(x, y)) + geom_point()

  # facet_wrap()
  p_wrap <- p + facet_wrap(vars(NULL))
  d_wrap <- layer_data(p_wrap)

  expect_equal(d_wrap$PANEL, factor(c(1L, 1L, 1L)))
  expect_equal(d_wrap$group, structure(c(-1L, -1L, -1L), n = 1L))

  # facet_grid()
  p_grid <- p + facet_grid(vars(NULL))
  d_grid <- layer_data(p_grid)

  expect_equal(d_grid$PANEL, factor(c(1L, 1L, 1L)))
  expect_equal(d_grid$group, structure(c(-1L, -1L, -1L), n = 1L))
})


test_that("facets with free scales scale independently", {
  df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3])
  p <- ggplot(df, aes(x, y)) + geom_point()

  # facet_wrap()
  l1 <- p + facet_wrap(~z, scales = "free")
  d1 <- cdata(l1)[[1]]
  expect_true(sd(d1$x) < 1e-10)
  expect_true(sd(d1$y) < 1e-10)

  # RHS of facet_grid()
  l2 <- p + facet_grid(. ~ z, scales = "free")
  d2 <- cdata(l2)[[1]]
  expect_true(sd(d2$x) < 1e-10)
  expect_length(unique(d2$y), 3)

  # LHS of facet_grid()
  l3 <- p + facet_grid(z ~ ., scales = "free")
  d3 <- cdata(l3)[[1]]
  expect_length(unique(d3$x), 3)
  expect_true(sd(d3$y) < 1e-10)
})

test_that("shrink parameter affects scaling", {
  df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3])

  l1 <- ggplot(df, aes(1, y)) + geom_point()
  r1 <- pranges(l1)

  expect_equal(r1$x[[1]], c(1, 1))
  expect_equal(r1$y[[1]], c(1, 3))

  l2 <- ggplot(df, aes(1, y)) + stat_summary(fun = "mean")
  r2 <- pranges(l2)
  expect_equal(r2$y[[1]], c(2, 2))

  l3 <- ggplot(df, aes(1, y)) + stat_summary(fun = "mean") +
    facet_null(shrink = FALSE)
  r3 <- pranges(l3)
  expect_equal(r3$y[[1]], c(1, 3))
})

test_that("facet variables", {
  expect_identical(facet_null()$vars(), character(0))
  expect_identical(facet_wrap(~ a)$vars(), "a")
  expect_identical(facet_grid(a ~ b)$vars(), c("a", "b"))
})

test_that("facet gives clear error if ", {
  df <- data_frame(x = 1)
  expect_snapshot_error(print(ggplot(df, aes(x)) + facet_grid(x ~ x)))
  expect_snapshot_error(print(ggplot(df, aes(x)) %>% facet_grid(. ~ x)))
  expect_snapshot_error(print(ggplot(df, aes(x)) + facet_grid(list(1, 2, 3))))
  expect_snapshot_error(print(ggplot(df, aes(x)) + facet_grid(vars(x), "free")))
})

test_that("facet_grid `axis_labels` argument can be overruled", {

  f <- facet_grid(vars(cyl), axes = "all", axis.labels = "all")
  expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE))

  f <- facet_grid(vars(cyl), axes = "all", axis.labels = "margins")
  expect_equal(f$params$axis_labels, list(x = FALSE, y = FALSE))

  # Overrule when only drawing at margins
  f <- facet_grid(vars(cyl), axes = "margins", axis.labels = "margins")
  expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE))

})

test_that("facet_wrap `axis_labels` argument can be overruled", {

  # The folllowing three should all draw axis labels
  f <- facet_wrap(vars(cyl), scales = "fixed", axes = "all", axis.labels = "all")
  expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE))

  f <- facet_wrap(vars(cyl), scales = "free", axes = "all", axis.labels = "all")
  expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE))

  f <- facet_wrap(vars(cyl), scales = "fixed", axes = "margins", axis.labels = "all")
  expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE))

  # The only case when labels shouldn't be drawn is when scales are fixed but
  # the axes are to be drawn
  f <- facet_wrap(vars(cyl), scales = "fixed", axes = "all", axis.labels = "margins")
  expect_equal(f$params$axis_labels, list(x = FALSE, y = FALSE))

  # Should draw labels because scales are free
  f <- facet_wrap(vars(cyl), scales = "free", axes = "all", axis.labels = "margins")
  expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE))

  # Should draw labels because only drawing at margins
  f <- facet_wrap(vars(cyl), scales = "fixed", axes = "margins", axis.labels = "margins")
  expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE))

})

test_that("facet_grid `axes` can draw inner axes.", {
  df <- data_frame(
    x = 1:4, y = 1:4,
    fx = c("A", "A", "B", "B"),
    fy = c("c", "d", "c", "d")
  )
  p <- ggplot(df, aes(x, y)) + geom_point()

  case <- ggplotGrob(p + facet_grid(vars(fy), vars(fx), axes = "all"))
  ctrl <- ggplotGrob(p + facet_grid(vars(fy), vars(fx), axes = "margins"))

  # 4 x-axes if all axes should be drawn
  bottom <- case$grobs[grepl("axis-b", case$layout$name)]
  expect_equal(sum(vapply(bottom, inherits, logical(1), "absoluteGrob")), 4)
  # 2 x-axes if drawing at the margins
  bottom <- ctrl$grobs[grepl("axis-b", ctrl$layout$name)]
  expect_equal(sum(vapply(bottom, inherits, logical(1), "absoluteGrob")), 2)

  # Ditto for y-axes
  left <- case$grobs[grepl("axis-l", case$layout$name)]
  expect_equal(sum(vapply(left, inherits, logical(1), "absoluteGrob")), 4)
  left <- ctrl$grobs[grepl("axis-l", ctrl$layout$name)]
  expect_equal(sum(vapply(left, inherits, logical(1), "absoluteGrob")), 2)
})

test_that("facet_wrap `axes` can draw inner axes.", {
  df <- data_frame(
    x = 1, y = 1, facet = LETTERS[1:4]
  )

  p <- ggplot(df, aes(x, y)) + geom_point()

  case <- ggplotGrob(p + facet_wrap(vars(facet), axes = "all"))
  ctrl <- ggplotGrob(p + facet_wrap(vars(facet), axes = "margins"))

  # 4 x-axes if all axes should be drawn
  bottom <- case$grobs[grepl("axis-b", case$layout$name)]
  expect_equal(sum(vapply(bottom, inherits, logical(1), "absoluteGrob")), 4)
  # 2 x-axes if drawing at the margins
  bottom <- ctrl$grobs[grepl("axis-b", ctrl$layout$name)]
  expect_equal(sum(vapply(bottom, inherits, logical(1), "absoluteGrob")), 2)

  # Ditto for y-axes
  left <- case$grobs[grepl("axis-l", case$layout$name)]
  expect_equal(sum(vapply(left, inherits, logical(1), "absoluteGrob")), 4)
  left <- ctrl$grobs[grepl("axis-l", ctrl$layout$name)]
  expect_equal(sum(vapply(left, inherits, logical(1), "absoluteGrob")), 2)
})

# Variable combinations ---------------------------------------------------

test_that("zero-length vars in combine_vars() generates zero combinations", {
  df <- data_frame(letter = c("a", "b"))
  expect_equal(nrow(combine_vars(list(df), vars = vars())), 0)
  expect_equal(ncol(combine_vars(list(df), vars = vars())), 0)
})

test_that("at least one layer must contain all facet variables in combine_vars()", {
  df <- data_frame(letter = c("a", "b"))
  expect_silent(combine_vars(list(df), vars = vars(letter = letter)))
  expect_snapshot_error(combine_vars(list(df), vars = vars(letter = number)))
})

test_that("at least one combination must exist in combine_vars()", {
  df <- data_frame(letter = character(0))
  expect_error(
    combine_vars(list(df), vars = vars(letter = letter)),
    "Faceting variables must have at least one value"
  )
})

test_that("combine_vars() generates the correct combinations", {
  df_one <- data_frame(
    letter = c("a", "b"),
    number = c(1, 2),
    boolean = c(TRUE, FALSE),
    factor = factor(c("level1", "level2"))
  )

  df_all <- expand.grid(
    letter = c("a", "b"),
    number = c(1, 2),
    boolean = c(TRUE, FALSE),
    factor = factor(c("level1", "level2")),
    stringsAsFactors = FALSE
  )
  attr(df_all, "out.attrs") <- NULL

  vars_all <- vars(letter = letter, number =  number, boolean = boolean, factor = factor)

  expect_equal(
    combine_vars(list(df_one), vars = vars_all),
    df_one
  )

  expect_equal(
    combine_vars(list(df_all), vars = vars_all),
    df_all
  )

  # with drop = FALSE the rows are ordered in the opposite order
  # NAs are dropped with drop = FALSE (except for NA factor values);
  # NAs are kept with with drop = TRUE
  # drop keeps all combinations of data, regardless of the combinations in which
  # they appear in the data (in addition to keeping unused factor levels)
  expect_equal(
    combine_vars(list(df_one), vars = vars_all, drop = FALSE),
    df_all[order(df_all$letter, df_all$number, df_all$boolean, df_all$factor), ],
    ignore_attr = TRUE   # do not compare `row.names`
  )

  expect_snapshot_error(
    combine_vars(
      list(data.frame(a = 1:2, b = 2:3), data.frame(a = 1:2, c = 2:3)),
      vars = vars(b=b, c=c)
    )
  )

  expect_snapshot_error(
    combine_vars(
      list(data.frame(a = 1:2), data.frame(b = numeric())),
      vars = vars(b=b)
    )
  )
})

test_that("drop = FALSE in combine_vars() keeps unused factor levels", {
  df <- data_frame(x = factor("a", levels = c("a", "b")))
  expect_equal(
    combine_vars(list(df), vars = vars(x = x), drop = TRUE),
    data_frame(x = factor("a", levels = c("a", "b")))
  )
  expect_equal(
    combine_vars(list(df), vars = vars(x = x), drop = FALSE),
    data_frame(x = factor(c("a", "b"), levels = c("a", "b")))
  )
})

test_that("combine_vars() generates the correct combinations with multiple data frames", {
  df <- expand.grid(letter = c("a", "b"), number = c(1, 2), boolean = c(TRUE, FALSE))

  vars <- vars(letter = letter, number = number)
  expect_identical(
    combine_vars(list(df), vars = vars),
    combine_vars(list(df, df), vars = vars)
  )
  expect_identical(
    combine_vars(list(df), vars = vars),
    combine_vars(list(df, df[character(0)]), vars = vars)
  )
  expect_identical(
    combine_vars(list(df), vars = vars),
    combine_vars(list(df, df["letter"]), vars = vars)
  )
  expect_identical(
    combine_vars(list(df), vars = vars),
    combine_vars(list(df, df[c("letter", "number")]), vars = vars)
  )
})

test_that("eval_facet() is tolerant for missing columns (#2963)", {
  expect_null(eval_facet(quo(2 * x), data_frame(foo = 1), possible_columns = c("x")))
  expect_null(eval_facet(quo(2 * .data$x), data_frame(foo = 1), possible_columns = c("x")))

  # Even if there's the same name of external variable, eval_facet() returns NULL before
  # reaching to the variable
  bar <- 2
  expect_null(eval_facet(quo(2 * bar), data_frame(foo = 1), possible_columns = c("bar")))
  # If there's no same name of columns, the external variable is used
  expect_equal(
    eval_facet(quo(2 * bar), data_frame(foo = 1), possible_columns = c("x")),
    4
  )

  # If the expression contains any non-existent variable, it fails
  expect_error(
    eval_facet(quo(no_such_variable * x), data_frame(foo = 1), possible_columns = c("x")),
    "object 'no_such_variable' not found"
  )
})

test_that("validate_facets() provide meaningful errors", {
  expect_snapshot_error(validate_facets(aes(var)))
  expect_snapshot_error(validate_facets(ggplot()))
})

test_that("check_layout() throws meaningful errors", {
  expect_snapshot_error(check_layout(mtcars))
})

# Visual tests ------------------------------------------------------------

test_that("facet labels respect both justification and margin arguments", {

  df <- data_frame(
    x = 1:2,
    y = 1:2,
    z = c("a", "aaaaaaabc"),
    g = c("b", "bbbbbbbcd")
  )

  base <- ggplot(df, aes(x, y)) +
    geom_point() +
    facet_grid(g ~ z) +
    theme_test()

  p1 <- base +
    theme(strip.text.x = element_text(hjust = 0, margin = margin(5, 5, 5, 5)),
          strip.text.y = element_text(hjust = 0, margin = margin(5, 5, 5, 5)))

  p2 <- base +
    theme(
      strip.text.x = element_text(
        angle = 90,
        hjust = 0,
        margin = margin(5, 5, 5, 5)
      ),
      strip.text.y = element_text(
        angle = 0,
        hjust = 0,
        margin = margin(5, 5, 5, 5)
      )
    )

  expect_doppelganger("left justified facet labels with margins", p1)
  expect_doppelganger("left justified rotated facet labels with margins", p2)
})

test_that("facet's 'axis_labels' argument correctly omits labels", {

  base <- ggplot(mtcars, aes(mpg, disp)) +
    geom_point() +
    guides(x = "axis", y = "axis", x.sec = "axis", y.sec = "axis")

  expect_doppelganger(
    "facet_grid with omitted inner axis labels",
    base + facet_grid(vars(cyl), vars(vs), axes = "all", axis.labels = "margins")
  )

  expect_doppelganger(
    "facet_wrap with omitted inner axis labels",
    base + facet_wrap(vars(cyl, vs), axes = "all", axis.labels = "margins")
  )
})