ggh4x: Hacks for 'ggplot2'

# Setup basic tests -------------------------------------------------------

# Setup nested data
df <- cbind.data.frame(
  iris,
  nester = ifelse(iris$Species == "setosa",
                  "Short Leaves", "Long Leaves")
)

# Setup a basic plot
basic <- ggplot(df)


# Basic tests -------------------------------------------------------------

test_that("facet_nested can be added to a plot", {
  g <- basic + facet_nested()
  expect_s3_class(g$facet, "gg")
  expect_s3_class(g$facet, "Facet")
  expect_s3_class(g$facet, "FacetGrid")
  expect_s3_class(g$facet, "FacetNested")
})

test_that("facet_nested can be build", {
  g <- basic + facet_nested(~ nester + Species)
  g <- ggplot_build(g)
  expect_s3_class(g, "ggplot_built")
  expect_s3_class(g$layout, "gg")
  expect_s3_class(g$layout, "Layout")
  expect_s3_class(g$plot, "gg")
  expect_s3_class(g$plot, "ggplot")
})

test_that("facet_nested can be interpreted as gtable", {
  # Build plots
  test <- basic + facet_nested(~ nester + Species)
  ctrl <- basic + facet_grid(~ nester + Species)

  # Convert to gtables
  test <- ggplotGrob(test)
  ctrl <- ggplotGrob(ctrl)

  # Tests
  expect_equal(class(ctrl), class(test))
  expect_s3_class(test, "gtable")
})

test_that("facet_nested splits up data", {
  # Build plots
  ctrl <- basic + facet_grid(~ nester + Species)
  hori <- basic + facet_nested(~ nester + Species)
  vert <- basic + facet_nested(nester + Species ~ .)

  # Grab data
  ctrl <- layer_data(ctrl)
  hori <- layer_data(hori)
  vert <- layer_data(vert)

  # Test
  expect_equal(hori$PANEL, factor(rep(c(3,1,2), each = 50)))
  expect_equal(hori, ctrl)
  expect_equal(hori, vert)
})

test_that("facet_nested returns helpful error messages", {
  # Upon misspelled formula
  ctrl <- basic + facet_nested(~ nester + Species)
  test <- basic + facet_nested(~ Nester + Species)
  ctrl <- expect_silent(layer_data(ctrl))
  test <- expect_error(layer_data(test), "Plot is missing")
})

# Strip nesting tests -----------------------------------------------------

test_that("facet_nested rejects invalid strips", {
  f <- quote(facet_nested(~ Species, strip = "dummy"))
  expect_error(eval(f), "valid facet strip")
})

test_that("facet_nested can draw multiple panel and strips", {
  # Build plots
  test <- basic + facet_nested(~ Species)
  ctrl <- basic + facet_grid(~ Species)

  # Grab gtable layout names
  test <- ggplotGrob(test)$layout$name
  ctrl <- ggplotGrob(ctrl)$layout$name

  # Grab metrics
  test_npanels <- sum(grepl("panel", test))
  test_nstrips <- sum(grepl("strip", test))
  ctrl_npanels <- sum(grepl("panel", ctrl))
  ctrl_nstrips <- sum(grepl("strip", ctrl))

  # Test
  expect_equal(test_npanels, ctrl_npanels)
  expect_equal(test_nstrips, ctrl_nstrips)
  expect_equal(test_npanels, 3)
  expect_equal(test_nstrips, 3)
})

test_that("facet_nested can nest strips", {
  # Build plots
  test <- basic + facet_nested(~ nester + Species)
  ctrl <- basic + facet_grid(~ nester + Species)

  # Grab gtable layout names
  test <- ggplotGrob(test)$layout$name
  ctrl <- ggplotGrob(ctrl)$layout$name

  # Grab metrics
  test_npanels <- sum(grepl("panel", test))
  test_nstrips <- sum(grepl("strip", test))
  ctrl_npanels <- sum(grepl("panel", ctrl))
  ctrl_nstrips <- sum(grepl("strip", ctrl))

  # Test
  expect_equal(test_npanels, ctrl_npanels)
  expect_equal(test_npanels, 3)
  expect_equal(test_nstrips, 5)
  expect_equal(ctrl_nstrips, 3)
})

# Nesting line tests ------------------------------------------------------

test_that("facet_nested constructor handles nesting lines", {
  f <- facet_nested(~ nester + Species, nest_line = TRUE)
  expect_s3_class(f$params$nest_line, 'element_line')
  f <- facet_nested(~ nester + Species, nest_line = FALSE)
  expect_s3_class(f$params$nest_line, "element_blank")
  f <- quote(facet_nested(~ nester + Species, nest_line = element_rect()))
  expect_error(eval(f))
})

test_that("facet_nested can draw nesting lines horizontally", {
  # Build gtable
  g <- basic + facet_nested(~ nester + Species, nest_line = TRUE)
  g <- ggplotGrob(g)
  strp <- g$grobs[g$layout$name == "strip-t-1"][[1]]

  # Grab metrics
  is_indicator <- grepl("nester", strp$layout$name)
  panel_xpos <- panel_cols(g)$l
  nestr_xpos <- strp$layout[is_indicator, c("l", "r")]

  # Test
  expect_equal(sum(is_indicator), 1)
})

test_that("facet_nested can draw nesting lines vertically", {
  # Build gtable
  g <- basic + facet_nested(nester + Species ~., nest_line = TRUE)
  g <- ggplotGrob(g)
  strp <- g$grobs[g$layout$name == "strip-r-1"][[1]]

  # Grab metrics
  is_indicator <- grepl("nester", strp$layout$name)
  panel_ypos <- panel_rows(g)$t
  nestr_ypos <- strp$layout[is_indicator, c("t", "b")]

  # Test
  expect_equal(sum(is_indicator), 1)
})

test_that("facet_nested `solo` arguments works as intended", {

  theme <- theme_get()
  params <- list(nest_line = element_line(), solo_line = TRUE,
                 resect = unit(0, "pt"))

  df <- data_frame(
    outer_x = c("A", "A", "B"),
    inner_x = c("X", "Y", 'Z'),
    outer_y = c("a", "b", "b"),
    inner_y = c("x", "y", "z")
  )

  topright <- facet_grid2(
    vars(outer_y, inner_y),
    vars(outer_x, inner_x),
    strip = strip_nested()
  )
  bottomleft <- facet_grid2(
    vars(outer_y, inner_y),
    vars(outer_x, inner_x),
    strip = strip_nested(),
    switch = "both"
  )

  topright   <- ggplotGrob(ggplot(df) + topright)
  bottomleft <- ggplotGrob(ggplot(df) + bottomleft)

  has_nestline <- function(gt, pattern) {
    vapply(
      gt$grobs[grepl(pattern, gt$layout$name)],
      function(x) any(grepl("nester", x$layout$name)),
      logical(1)
    )
  }

  # Test top/right strips with solo nest lines
  g <- add_nest_indicator(topright, params, theme)
  has_nester <- has_nestline(g, "^strip-r")
  expect_equal(has_nester, c(TRUE, TRUE, FALSE, FALSE, FALSE))
  has_nester <- has_nestline(g, "^strip-t")
  expect_equal(has_nester, c(TRUE, TRUE, FALSE, FALSE, FALSE))

  # Test top/right strips without solo nest lines
  params$solo_line <- FALSE
  g <- add_nest_indicator(topright, params, theme)
  has_nester <- has_nestline(g, "^strip-r")
  expect_equal(has_nester, c(FALSE, TRUE, FALSE, FALSE, FALSE))
  has_nester <- has_nestline(g, "^strip-t")
  expect_equal(has_nester, c(TRUE, FALSE, FALSE, FALSE, FALSE))

  # Test bottom/left strips with solo nest lines
  params$solo_line <- TRUE
  g <- add_nest_indicator(bottomleft, params, theme)
  has_nester <- has_nestline(g, "^strip-l")
  expect_equal(has_nester, c(TRUE, TRUE, FALSE, FALSE, FALSE))
  has_nester <- has_nestline(g, "^strip-b")
  expect_equal(has_nester, c(TRUE, TRUE, FALSE, FALSE, FALSE))

  # Test bottom/left strips without solo nest lines
  params$solo_line <- FALSE
  g <- add_nest_indicator(bottomleft, params, theme)
  has_nester <- has_nestline(g, "^strip-l")
  expect_equal(has_nester, c(FALSE, TRUE, FALSE, FALSE, FALSE))
  has_nester <- has_nestline(g, "^strip-b")
  expect_equal(has_nester, c(TRUE, FALSE, FALSE, FALSE, FALSE))
})

test_that("facet_nested line resection works", {
  # Build gtable
  test <- basic + facet_nested(~ nester + Species,
                               nest_line = TRUE,
                               resect = grid::unit(10, "mm"))
  ctrl <- basic + facet_nested(~ nester + Species,
                               nest_line = TRUE,
                               resect = grid::unit(0, "mm"))
  test <- ggplotGrob(test)
  ctrl <- ggplotGrob(ctrl)
  test <- test$grobs[test$layout$name == "strip-t-1"][[1]]
  ctrl <- ctrl$grobs[ctrl$layout$name == "strip-t-1"][[1]]

  # Grab metrics
  test <- test$grobs[[grep("nester", test$layout$name)]]
  ctrl <- ctrl$grobs[[grep("nester", ctrl$layout$name)]]

  test_width <- grid::convertWidth(test$x, "mm", valueOnly = TRUE)
  ctrl_width <- grid::convertWidth(ctrl$x, "mm", valueOnly = TRUE)

  # Tests
  expect_false(any(test_width == ctrl_width))
  expect_equal(test$x[1], unit(0, "npc") +  1 * unit(10, "mm"))
  expect_equal(test$x[2], unit(1, "npc") + -1 * unit(10, "mm"))
})




# Setup bleed tests -------------------------------------------------------

df <- data.frame(outer = c(1,2,2),
                 inner = c(3,3,4),
                 x = 0, y = 0)

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


# Bleed tests -------------------------------------------------------------

test_that("setting argument directly begets warnings", {
  f <- quote(facet_nested(~ outer + inner, bleed = "dummy"))
  expect_warning(eval(f))
})

test_that("facet_nested can bleed horizontally", {
  # Setup gtable layouts
  ctrl <- bleed + facet_nested(~ outer + inner,
                               strip = strip_nested(bleed = FALSE))
  test <- bleed + facet_nested(~ outer + inner,
                               strip = strip_nested(bleed = TRUE))

  ctrl <- ggplotGrob(ctrl)
  test <- ggplotGrob(test)
  ctrl <- ctrl$layout[grepl("strip", ctrl$layout$name),]
  test <- test$layout[grepl("strip", test$layout$name),]

  # Grab metrics
  ctrl_nstrips <- nrow(ctrl)
  test_nstrips <- nrow(test)

  expect_false(ctrl_nstrips == test_nstrips)
  expect_gt(ctrl_nstrips, test_nstrips)
  expect_equal(test_nstrips, 4)
  expect_equal(ctrl_nstrips, 5)
})

test_that("facet_nested horizontal bleeding works", {
  # Setup gtable layouts
  ctrl <- bleed + facet_nested(~ outer + inner,
                               strip = strip_nested(bleed = FALSE))
  test <- bleed + facet_nested(~ outer + inner,
                               strip = strip_nested(bleed = TRUE))

  ctrl <- ggplotGrob(ctrl)
  test <- ggplotGrob(test)
  ctrl <- ctrl$layout[grepl("strip", ctrl$layout$name),]
  test <- test$layout[grepl("strip", test$layout$name),]

  # Grab metrics
  ctrl_nstrips <- nrow(ctrl)
  test_nstrips <- nrow(test)

  # Top and bottom positions should be the same
  expect_equal(test$t, test$b)
  expect_equal(ctrl$t, ctrl$b)

  # Left and right positions should differ based on bleeding
  expect_equal(sum(test$l == test$r), 2)
  expect_equal(sum(ctrl$l == ctrl$r), 4)

  # Test unequal strips
  expect_equal(which(test$l != test$r), c(2, 3))
  expect_lt(test$l[2], test$r[2])
  expect_lt(test$l[3], test$r[3])

  expect_equal(which(ctrl$l != ctrl$r), 2)
  expect_lt(ctrl$l[2], ctrl$r[2])
})

test_that("facet_nested can bleed vertically", {
  # Setup gtable layouts
  ctrl <- bleed + facet_nested(outer + inner ~ .,
                               strip = strip_nested(bleed = FALSE))
  test <- bleed + facet_nested(outer + inner ~ .,
                               strip = strip_nested(bleed = TRUE))

  ctrl <- ggplotGrob(ctrl)
  test <- ggplotGrob(test)
  ctrl <- ctrl$layout[grepl("strip", ctrl$layout$name),]
  test <- test$layout[grepl("strip", test$layout$name),]

  # Grab metrics
  ctrl_nstrips <- nrow(ctrl)
  test_nstrips <- nrow(test)

  expect_false(ctrl_nstrips == test_nstrips)
  expect_gt(ctrl_nstrips, test_nstrips)
  expect_equal(test_nstrips, 4)
  expect_equal(ctrl_nstrips, 5)
})

test_that("facet_nested vertical bleeding works", {
  # Setup gtable layouts
  ctrl <- bleed + facet_nested(outer + inner ~ .,
                               strip = strip_nested(bleed = FALSE))
  test <- bleed + facet_nested(outer + inner ~ .,
                               strip = strip_nested(bleed = TRUE))

  ctrl <- ggplotGrob(ctrl)
  test <- ggplotGrob(test)
  ctrl <- ctrl$layout[grepl("strip", ctrl$layout$name),]
  test <- test$layout[grepl("strip", test$layout$name),]

  # Left and right positions should be the same
  expect_equal(test$l, test$r)
  expect_equal(ctrl$l, ctrl$r)

  # Left and right positions should differ based on bleeding
  expect_equal(sum(test$t == test$b), 2)
  expect_equal(sum(ctrl$t == ctrl$b), 4)

  # Test unequal strips
  expect_equal(which(test$t != test$b), c(2, 3))
  expect_lt(test$t[2], test$b[2])
  expect_lt(test$t[3], test$b[3])

  expect_equal(which(ctrl$t != ctrl$b), 2)
  expect_lt(ctrl$t[2], ctrl$b[2])
})


# Miscellaneous tests -----------------------------------------------------

test_that("facet_nested handles combined datasets with missing inner variables", {
  df1 <- data.frame(outer = 1,
                    inner = LETTERS[1:2],
                    x = 0, y = 0)
  df2 <- data.frame(outer = 2,
                    x = 0, y = 0)

  g <- ggplot() +
    geom_point(data = df1, aes(x, y)) +
    geom_point(data = df2, aes(x, y))

  test <- ggplotGrob(g + facet_nested(~ outer + inner))
  ctrl <- ggplotGrob(g + facet_grid(~ outer + inner))
  strp_test <- test$grobs[grepl("strip", test$layout$name)]
  strp_ctrl <- ctrl$grobs[grepl("strip", ctrl$layout$name)]
  test_is_strip <- grepl("strip", strp_test$layout$name)
  ctrl_is_strip <- grepl("strip", strp_ctrl$layout$name)

  test_striplabels <- sapply(strp_test, function(strip){
    titles <- sapply(strip$grobs, function(grob){
      title <- grob$children[[2]]$children[[1]]$label
    })
  })

  ctrl_striplabels <- sapply(strp_ctrl, function(strip){
    titles <- sapply(strip$grobs, function(grob){
      title <- grob$children[[2]]$children[[1]]$label
    })
  })
  ctrl_striplabels <- as.vector(ctrl_striplabels)

  expect_false(length(test_striplabels) == length(ctrl_striplabels))
  expect_equal(length(ctrl_striplabels) - length(test_striplabels), 3)
  expect_equal(ctrl_striplabels, c("1", "A", "1", "B", "2", "A", "2", 'B'))
  expect_equal(test_striplabels, c("1", "2", "A", "B", ""))
})