tests/testthat/test-fboxplot.R

In tidyfun: Tidy Functional Data Wrangling and Visualization

make_fboxplot_data <- function() {
  arg <- seq(0, 1, length.out = 21)
  curves <- rbind(
    1.0 + 0.10 * sin(2 * pi * arg),
    1.0 + 0.12 * sin(2 * pi * arg + 0.1),
    0.98 + 0.09 * sin(2 * pi * arg - 0.1),
    1.55 + 0.10 * sin(2 * pi * arg),
    1.2 + 0.08 * cos(2 * pi * arg),
    1.22 + 0.09 * cos(2 * pi * arg + 0.1),
    1.18 + 0.08 * cos(2 * pi * arg - 0.1),
    1.75 + 0.10 * cos(2 * pi * arg)
  )

  data.frame(
    id = seq_len(nrow(curves)),
    grp = factor(rep(c("A", "B"), each = 4)),
    facet_grp = factor(rep(c("left", "right"), times = 4))
  ) |>
    dplyr::mutate(func = tfd(curves, arg = arg))
}

test_that("geom_fboxplot builds on tf_ggplot", {
  data <- make_fboxplot_data()

  p <- tf_ggplot(data, aes(tf = func)) + geom_fboxplot()
  built <- ggplot_build(p)
  plot_data <- built$data[[1]]

  expect_true(all(
    c(".fbox_component", ".fbox_stat_group") %in% names(plot_data)
  ))
  expect_true(all(
    c("box", "median", "whisker_lower", "whisker_upper") %in%
      unique(plot_data$.fbox_component)
  ))
})

test_that("geom_fboxplot sets tf axis labels like standard tf geoms", {
  data <- make_fboxplot_data()

  p <- tf_ggplot(data, aes(tf = func)) + geom_fboxplot()
  built <- ggplot_build(p)

  expect_equal(built$plot$labels$y, "func")
  expect_equal(built$plot$labels$x, "func.arg")
})

test_that("geom_fboxplot swaps default axis labels for horizontal orientation", {
  data <- make_fboxplot_data()

  p <- tf_ggplot(data, aes(tf = func)) + geom_fboxplot(orientation = "y")
  built <- ggplot_build(p)

  expect_equal(built$plot$labels$x, "func")
  expect_equal(built$plot$labels$y, "func.arg")
})

test_that("geom_fboxplot groups within a panel by fill and colour", {
  data <- make_fboxplot_data()

  p <- tf_ggplot(data, aes(tf = func, fill = grp, colour = grp)) +
    geom_fboxplot()
  built <- ggplot_build(p)

  expect_equal(length(unique(built$data[[1]]$.fbox_stat_group)), 2)
})

test_that("geom_fboxplot uses mapped colour for ribbons when fill is absent", {
  data <- make_fboxplot_data()

  p <- tf_ggplot(data, aes(tf = func, colour = grp)) + geom_fboxplot()
  panel_grob <- ggplotGrob(p)$grobs[[which(
    ggplotGrob(p)$layout$name == "panel"
  )]]
  layer_grob <- panel_grob$children[[3]]
  polygon_idx <- grepl("^geom_polygon", names(layer_grob$children))
  fills <- vapply(
    layer_grob$children[polygon_idx],
    \(g) g$gp$fill,
    character(1)
  )

  expect_equal(length(unique(fills)), 2)
})

test_that("geom_fboxplot is compatible with facetting", {
  data <- make_fboxplot_data()

  p <- tf_ggplot(data, aes(tf = func, fill = grp, colour = grp)) +
    geom_fboxplot() +
    facet_wrap(~facet_grp)
  built <- ggplot_build(p)

  expect_equal(as.character(sort(unique(built$data[[1]]$PANEL))), c("1", "2"))
})

test_that("geom_fboxplot handles irregular tf data on common support", {
  p <- tf_ggplot(tidyfun::dti_df, aes(tf = rcst)) + geom_fboxplot()

  expect_no_warning(built <- ggplot_build(p))
  expect_true(nrow(built$data[[1]]) > 0)
})

test_that("geom_fboxplot is compatible with scaled axes", {
  data <- make_fboxplot_data()

  p <- tf_ggplot(data, aes(tf = func)) +
    geom_fboxplot() +
    scale_y_log10()
  built <- ggplot_build(p)
  numeric_cols <- intersect(
    c("x", "y", "ymin", "ymax", "xmin", "xmax"),
    names(built$data[[1]])
  )

  expect_true(length(numeric_cols) > 0)
  expect_true(all(vapply(
    built$data[[1]][numeric_cols],
    \(x) all(is.finite(x[!is.na(x)])),
    logical(1)
  )))
})

test_that("geom_fboxplot stat output is retransformed by y scales", {
  data <- make_fboxplot_data()
  data <- dplyr::mutate(data, pos_func = exp(func) + 100)

  p <- tf_ggplot(data, aes(tf = pos_func, fill = grp)) +
    geom_fboxplot() +
    scale_y_log10()
  built <- ggplot_build(p)
  numeric_cols <- intersect(
    c("y", "ymin", "ymax", "xmin", "xmax"),
    names(built$data[[1]])
  )
  vals <- unlist(built$data[[1]][numeric_cols])
  vals <- vals[is.finite(vals)]

  expect_true(max(vals) < 3)
  expect_true(min(vals) > 1)
})

test_that("geom_fboxplot supports flipped orientation", {
  data <- make_fboxplot_data()

  p <- tf_ggplot(data, aes(tf = func)) +
    geom_fboxplot(orientation = "y")
  built <- ggplot_build(p)
  plot_data <- built$data[[1]]

  expect_true(all(c("x", "y") %in% names(plot_data)))
  expect_true(all(
    c("xmin", "xmax") %in%
      names(plot_data[plot_data$.fbox_component == "box", ])
  ))
})

test_that("geom_fboxplot accepts custom depth and fence functions", {
  data <- make_fboxplot_data()

  depth_fn <- function(x, arg = NULL) {
    rev(seq_along(x))
  }
  fence_fn <- function(
    tf_vec,
    arg,
    depth,
    median,
    central_lower,
    central_upper,
    coef,
    central
  ) {
    list(
      lower = central_lower - 0.01,
      upper = central_upper + 0.01,
      outliers = c(rep(FALSE, length(tf_vec) - 1), TRUE)
    )
  }

  p <- tf_ggplot(data, aes(tf = func)) +
    geom_fboxplot(depth_fn = depth_fn, fence_fn = fence_fn)
  built <- ggplot_build(p)

  expect_true(any(built$data[[1]]$.fbox_component == "outlier"))
})