tests/testthat/test-facet_wrap2.R

In teunbrand/ggh4x: Hacks for 'ggplot2'

strip_layout <- function(p) {
  data <- ggplot_build(p)
  plot <- data$plot
  layout <- data$layout
  data <- data$data
  theme <- ggplot2:::plot_theme(plot)

  geom_grobs <- Map(function(l, d) { l$draw_geom(d, layout) },
                    plot$layers, data)


  facet <- layout$render(geom_grobs, data, theme, plot$labels)
  layout <- facet$layout
  strip_layout <- layout[grepl("^strip", layout$name), 1:4]
  as.list(strip_layout)
}

p <- ggplot(mtcars, aes(disp, drat)) + geom_point()

test_that("facet_wrap2() builds correct output", {
  wrap <- p + facet_wrap2(~cyl, axes = "all", remove_labels = "y")

  wrap_expected <- list(
    t = c(3, 3, 3),
    l = c(3, 7, 11),
    b = c(3, 3, 3),
    r = c(3, 7, 11)
  )

  expect_equal(strip_layout(wrap), wrap_expected)
})

grab_axis <- function(gt, where = "b") {
  gt$grobs[grepl(paste0("^axis-", where), gt$layout$name)]
}

nchildren <- function(gt, where) {
  axis <- grab_axis(gt, where)
  vapply(axis, function(x){
    if (!length(x$children)) {
      return(0L)
    }
    x <- x$children
    x <- x[names(x) == "axis"][[1]]
    length(x$grobs)
  }, integer(1))
}

test_that("facet_wrap2() can some repeat axes", {
  case <- p + facet_wrap2(am ~ cyl, axes = "x", dir = "v")
  ctrl <- p + facet_wrap2(am ~ cyl, axes = "margins", dir = "v")

  case <- ggplotGrob(case)
  ctrl <- ggplotGrob(ctrl)

  case <- grab_axis(case, "b")
  ctrl <- grab_axis(ctrl, "b")

  case <- vapply(case, ggplot2:::is.zero, logical(1))
  ctrl <- vapply(ctrl, ggplot2:::is.zero, logical(1))

  expect_equal(sum(case), 0L)
  expect_equal(sum(ctrl), 4L)
})

test_that("facet_wrap2 respects aspect ratio", {
  case_null <- p + facet_wrap2(~ vs)
  case_asp  <- case_null + theme(aspect.ratio = 2)

  case_null <- ggplotGrob(case_null)
  case_asp  <- ggplotGrob(case_asp)

  panel_col <- panel_cols(case_null)$l
  panel_row <- panel_rows(case_null)$t

  expect_equal(as.character(case_null$widths[panel_col]), c("1null", "1null"))
  expect_equal(as.character(case_asp$widths[panel_col]),  c("1null", "1null"))

  expect_equal(as.character(case_null$heights[panel_row]), "1null")
  expect_equal(as.character(case_asp$heights[panel_row]),  "2null")

  expect_false(case_null$respect)
  expect_true(case_asp$respect)
})

test_that("facet_wrap2() can remove some labels", {
  case1 <- p + facet_wrap2(am~cyl, axes = "all", remove_labels = "y")
  case2 <- p + facet_wrap2(am~cyl, axes = "all", remove_labels = "x")
  ctrl1 <- p + facet_wrap2(am~cyl, axes = "margins")
  ctrl2 <- p + facet_wrap2(am~cyl, axes = "all", remove_labels = "none")

  # Convert to gtables
  case1 <- ggplotGrob(case1)
  case2 <- ggplotGrob(case2)
  ctrl1 <- ggplotGrob(ctrl1)
  ctrl2 <- ggplotGrob(ctrl2)

  # Compare x-axis
  if (!new_guide_system) {
    expect_equal(nchildren(case1, "b"), rep(2L, 6))
    expect_equal(nchildren(case2, "b"), c(2L, 2L, 2L, 1L, 1L, 1L))
    expect_equal(nchildren(ctrl1, "b"), c(2L, 2L, 2L, 0L, 0L, 0L))
    expect_equal(nchildren(ctrl2, "b"), rep(2L, 6))
  } else {
    expect_equal(nchildren(case1, "b"), rep(3L, 6))
    expect_equal(nchildren(case2, "b"), c(3L, 3L, 3L, 2L, 2L, 2L))
    expect_equal(nchildren(ctrl1, "b"), c(3L, 3L, 3L, 0L, 0L, 0L))
    expect_equal(nchildren(ctrl2, "b"), rep(3L, 6))
  }

  # Compare y-axis
  if (!new_guide_system) {
    expect_equal(nchildren(case1, "l"), c(1L, 1L, 1L, 1L, 2L, 2L))
    expect_equal(nchildren(case2, "l"), rep(2L, 6))
    expect_equal(nchildren(ctrl1, "l"), c(0L, 0L, 0L, 0L, 2L, 2L))
    expect_equal(nchildren(ctrl2, "l"), rep(2L, 6))
  } else {
    expect_equal(nchildren(case1, "l"), c(2L, 2L, 2L, 2L, 3L, 3L))
    expect_equal(nchildren(case2, "l"), rep(3L, 6))
    expect_equal(nchildren(ctrl1, "l"), c(0L, 0L, 0L, 0L, 3L, 3L))
    expect_equal(nchildren(ctrl2, "l"), rep(3L, 6))
  }
})