tests/testthat/test-strips.R

In teunbrand/ggh4x: Hacks for 'ggplot2'

# Construction ------------------------------------------------------------

test_that("strip_vanilla can instantiate Strips", {
  test <- strip_vanilla()
  expect_s3_class(test, c("Strip", "ggproto"))
})

test_that("strip_themed can instantiate Strips", {
  test <- strip_themed()
  expect_s3_class(test, c("StripThemed", "Strip", "ggproto"))
})

test_that("strip_nested can instantiate Strips", {
  test <- strip_nested()
  expect_s3_class(test, c("StripNested", "StripThemed", "Strip", "ggproto"))
})

# Correctness -------------------------------------------------------------

# `strip_vanilla()` and `strip_nested()` are assumed to be tested sufficiently
# in `facet_wrap2()`/`facet_grid2()` and `facet_nested_wrap()`/`facet_nested()`
# respectively.
# Therefore, we just need to test `strip_themed` for correctness.

test_that("strip_themed inherits from theme", {
  my_theme <- theme_get() + theme(
    strip.background.x = element_rect(colour = "green", fill = "blue"),
    strip.text.y = element_text(family = "mono", colour = "red")
  )

  strip <- strip_themed(
    background_x = list(NULL, element_rect(colour = "blue"),
                        element_rect(fill = "green"))
  )
  elem <- strip$setup_elements(my_theme, "wrap")
  bg <- lapply(elem$background$x, `[[`, "gp")
  bg <- lapply(bg, unclass)

  # Backgrounds should already have been rendered as grobs
  # First element was NULL, so should be directly from theme
  expect_equal(bg[[1]][c("col", "fill")], list(col = "green", fill = "blue"))
  # Only fill comes from theme, col was specified
  expect_equal(bg[[2]][c("col", "fill")], list(col = "blue", fill = "blue"))
  # Only colour comes from theme, fill was specified
  expect_equal(bg[[3]][c("col", "fill")], list(col = "green", fill = "green"))

  strip <- strip_themed(
    text_y = list(element_blank(), element_text(family = "serif"))
  )
  elem <- strip$setup_elements(my_theme, "wrap")
  txt <- elem$text$y$left
  # Text should still be elements
  # First one was blank
  expect_equal(txt[[1]], element_blank())
  # Second one should have overwritten family but inherited colour
  expect_equal(txt[[2]][c("colour", "family")],
               list(colour = "red", family = "serif"))
  # Third one should not be evaluated until strip is placed
  expect_length(txt, 2)
})

test_that("strip_themed uses by_layer arguments correctly", {
  individ <- strip_themed(
    background_y = elem_list_rect(fill = c("green", "blue")),
    by_layer_y = FALSE
  )
  extra <- if (new_guide_system) 2L else 0L

  layered <- strip_themed(
    background_y = elem_list_rect(fill = c("green", "blue")),
    by_layer_y = TRUE
  )

  p <- ggplot(mpg, aes(displ, hwy)) +
    geom_point()

  individ <- p +
    facet_wrap2(
      vars("Top layer", drv), strip.position = "right", strip = individ
    )
  layered <- p +
    facet_wrap2(
      vars("Top layer", drv), strip.position = "right", strip = layered
    )
  individ <- ggplotGrob(individ)
  layered <- ggplotGrob(layered)

  # Test individual
  is_strip <- grepl("^strip-r-", individ$layout$name)
  lay <- individ$layout[is_strip,]
  expect_equal(lay[c("t", "l")],
               list(t = c(7, 7, 7) + extra, l = c(6, 11, 16) + extra),
               ignore_attr = TRUE)
  individ <- individ$grobs[is_strip]
  individ <- vapply(individ, function(x) {
    fills <- vapply(x$grobs, function(y) {
      y$children[[grep("^GRID\\.rect", names(y$children))]]$gp$fill
    }, character(1))
  }, character(2))
  expect_equal(as.vector(individ),
               c("green", "blue", "blue", "green", "green", "blue"))

  # Test layered
  is_strip <- grepl("^strip-r-", layered$layout$name)
  lay <- layered$layout[is_strip,]
  expect_equal(lay[c("t", "l")],
               list(t = c(7, 7, 7) + extra, l = c(6, 11, 16) + extra),
               ignore_attr = TRUE)
  layered <- layered$grobs[is_strip]
  layered <- vapply(layered, function(x) {
    fills <- vapply(x$grobs, function(y) {
      y$children[[grep("^GRID\\.rect", names(y$children))]]$gp$fill
    }, character(1))
  }, character(2))
  expect_equal(as.vector(layered),
               rep(c("green", "blue"), 3))
})

# Warnings and errors -----------------------------------------------------

test_that("strip_vanilla rejects faulty arguments", {
  expect_snapshot_error(strip_vanilla(clip = "nonsense"))
  expect_snapshot_error(strip_vanilla(size = "nonsense"))
})

test_that("strip_themed rejects faulty theme elements", {
  expect_snapshot_error(strip_themed(background_x = "I'm not a theme element"))
  expect_snapshot_error(strip_themed(text_y = element_line(colour = "blue")))
})