tests/testthat/test-facet_manual.R

In teunbrand/ggh4x: Hacks for 'ggplot2'

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

test_that("facet_manual can be constructed", {
  test <- facet_manual(vars(a), design = "A")
  expect_s3_class(test, c("FacetManual", "FacetWrap2", "FacetWrap"))
})

test_that("facet_manual returns facet_null without vars", {
  test <- facet_manual(vars(), design = "A")
  expect_s3_class(test, c("FacetNull", "Facet"))
})

test_that("facet_manual matches widths/heights to design", {
  test <- facet_manual(vars(a), design = matrix(c(1,1,2,2), 2, 2),
                       widths = 1, height = c(0.5, 2))
  test <- test$params[c("widths", "heights")]
  expect_equal(test$widths, unit(c(1, 1), "null"))
  expect_equal(test$heights, unit(c(0.5, 2), "null"))
})

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

test_that("facet_manual rejects some designs", {
  expect_snapshot_error(validate_design(list(1, "A")))

  expect_snapshot_error(validate_design("AA\nB"))

  expect_snapshot_error(validate_design(NULL))
})

test_that("facet_manual can build correct plots", {
  design <- "
   A##
   AB#
   #BC
   ##C
  "
  p <- ggplot(mtcars, aes(mpg, wt)) +
    geom_point() +
    facet_manual(vars(cyl), design)
  p <- ggplot_build(p)

  gt <- ggplot_gtable(p)$layout

  extra <- if (new_guide_system) 2 else 0

  # Test panel positions
  panels <- gt[grepl("^panel-", gt$name), , drop = FALSE]
  expect_equal(unlist(panels[1:4], use.names = FALSE),
               c(8, 12, 17, 5, 9, 13, 12, 17, 20, 5, 9, 13) + extra)
  # Test axis positions
  axes_b <- gt[grepl("^axis-b-", gt$name), , drop = FALSE]
  expect_equal(unname(panels$b), unname(axes_b$b - 1))
  axes_l <- gt[grepl("^axis-l-", gt$name), , drop = FALSE]
  expect_equal(unname(panels$l), unname(axes_l$l) + 1)
  # Test strip positions
  strips <- gt[grepl("^strip-t-", gt$name), , drop = FALSE]
  expect_equal(unname(panels$t), unname(strips$t) + 1)
})

test_that("facet_manual can assume layouts", {
  design <- matrix(c(3,3,2,1), 2, 2)
  p <- ggplot(mtcars, aes(mpg, wt)) +
    geom_point() +
    facet_manual(vars(cyl), design, strip.position = "right") +
    scale_x_continuous(position = "top") +
    scale_y_continuous(position = "right") +
    theme(strip.placement = "outside")
  p <- ggplot_build(p)

  gtab <- ggplot_gtable(p)
  gt <- gtab$layout

  # Test panel positions
  extra <- if (new_guide_system) 2 else 0
  panels <- gt[grepl("^panel-", gt$name), , drop = FALSE]
  expect_equal(unlist(panels[1:4], use.names = FALSE),
               c(11, 7, 7, 11, 11, 5, 11, 7, 11, 11, 11, 5) + extra)
  # Test axis positions
  axes_t <- gt[grepl("^axis-t-", gt$name), , drop = FALSE]
  expect_equal(unname(panels$t), unname(axes_t$t) + 1)
  axes_r <- gt[grepl("^axis-r-", gt$name), , drop = FALSE]
  expect_equal(unname(panels$r), unname(axes_r$r) - 1)
  # Test strip positions
  strips <- gt[grepl("^strip-r-", gt$name), , drop = FALSE]
  # 1 offset for axis, 1 offset for padding, 1 offset for strip
  expect_equal(unname(panels$r), unname(strips$r) - 3)
})

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