tests/testthat/test-visualization.R

In artma: Automatic Replication Tools for Meta-Analysis

box::use(
  testthat[
    expect_equal,
    expect_error,
    expect_false,
    expect_identical,
    expect_message,
    expect_null,
    expect_true,
    test_that
  ],
  withr[local_options, local_tempdir],
  artma / visualization / colors[
    VALID_THEMES,
    PALETTES,
    validate_theme,
    get_colors,
    get_tokens,
    get_neutral,
    get_background,
    get_vline_color
  ],
  artma / visualization / theme[get_theme],
  artma / visualization / export[
    BASE_PNG_DEVICE_OPTION,
    base_png_device,
    ensure_export_dir,
    build_export_filename,
    save_plot,
    save_plot_html,
    use_ragg_png_device
  ],
  artma / visualization / options[
    get_visualization_options,
    set_visualization_option,
    get_valid_themes
  ]
)

# colors --------------------------------------------------------------------

test_that("validate_theme accepts known themes and rejects unknown ones", {
  expect_true(validate_theme("blue"))
  expect_error(validate_theme("chartreuse"))
  expect_error(validate_theme(c("blue", "red")))
})

test_that("get_colors returns the exact box_plot palette", {
  expect_equal(
    get_colors("blue", "box_plot"),
    list(outlier = "#3B6EA5", fill = "#DCE6F2", border = "#1F4470")
  )
})

test_that("get_colors returns a single hex for the funnel palette", {
  expect_equal(get_colors("red", "funnel_plot"), "#C0553C")
})

test_that("get_colors resolves submethods", {
  expect_equal(get_colors("blue", "t_stat_histogram", "density"), "#1F4470")
})

test_that("get_colors aborts on unknown method or submethod", {
  expect_error(get_colors("blue", "no_such_method"))
  expect_error(get_colors("blue", "t_stat_histogram", "no_such_submethod"))
})

test_that("get_background and get_vline_color return theme hex codes", {
  expect_equal(get_background("yellow"), "#FDFCF7")
  expect_equal(get_vline_color("blue"), "#C4462B")
})

test_that("VALID_THEMES lists the five supported themes", {
  expect_equal(VALID_THEMES, c("blue", "yellow", "green", "red", "purple"))
})

test_that("get_tokens exposes the full accent family for every theme", {
  required <- c("accent", "accent_dark", "accent_light", "contrast", "highlight")
  for (theme_name in VALID_THEMES) {
    tokens <- get_tokens(theme_name)
    expect_true(all(required %in% names(tokens)))
    expect_true(all(grepl("^#[0-9A-Fa-f]{6}$", unlist(tokens))))
  }
})

test_that("get_neutral returns one neutral or the whole set", {
  expect_equal(get_neutral("grid"), "#E5E5E9")
  expect_true(is.list(get_neutral()))
  expect_error(get_neutral("chartreuse"))
})

test_that("grouped plots use qualitative palettes, never sequential ones", {
  # A sequential ramp implies an ordering that an unordered grouping variable
  # does not have, and renders its lightest classes invisibly on a white panel.
  sequential <- c(
    "Reds", "Blues", "Greens", "Purples", "Oranges", "Greys",
    "YlOrRd", "YlOrBr", "YlGnBu", "YlGn", "BuPu", "OrRd", "PuBu"
  )
  categorical <- c(
    unlist(PALETTES$prima_facie$histogram),
    unlist(PALETTES$prima_facie$density),
    unlist(PALETTES$bpe$miracle),
    unlist(PALETTES$bpe$density)
  )
  expect_false(any(categorical %in% sequential))
})

test_that("every theme keeps its accent, contrast and highlight distinct", {
  for (theme_name in VALID_THEMES) {
    tokens <- get_tokens(theme_name)
    reference_hues <- c(tokens$accent, tokens$contrast, tokens$highlight)
    expect_equal(length(unique(reference_hues)), 3L)
  }
})

# theme ---------------------------------------------------------------------

test_that("get_theme returns a ggplot2 theme object", {
  th <- get_theme("green")
  expect_true(inherits(th, "theme"))
  expect_true(inherits(th, "gg"))
})

test_that("get_theme rejects invalid themes", {
  expect_error(get_theme("mauve"))
})

test_that("get_theme returns a complete theme", {
  # A partial theme() would be merged into ggplot2's default theme_grey(),
  # leaving grey panels, facet strips and legend keys wherever an element is
  # not named explicitly.
  expect_true(attr(get_theme("blue"), "complete"))
})

test_that("get_theme paints the panel and the plot on one surface", {
  th <- get_theme("blue")
  expect_equal(th$panel.background$fill, th$plot.background$fill)
  expect_equal(th$plot.background$fill, get_background("blue"))
})

test_that("get_theme scales every element from base_size", {
  small <- get_theme("blue", base_size = 10)
  large <- get_theme("blue", base_size = 20)
  expect_equal(small$text$size, 10)
  expect_equal(large$text$size, 20)
  expect_error(get_theme("blue", base_size = -1))
})

# export --------------------------------------------------------------------

test_that("build_export_filename follows the documented naming scheme", {
  expect_equal(build_export_filename("box_plot", "country"), "box_plot_country.png")
  expect_equal(build_export_filename("box_plot", "country", index = 2), "box_plot_country_2.png")
  expect_equal(build_export_filename("funnel", "year", extension = "pdf"), "funnel_year.pdf")
})

test_that("ensure_export_dir creates the directory", {
  base <- local_tempdir()
  target <- file.path(base, "nested", "graphics")
  expect_false(dir.exists(target))
  ensure_export_dir(target)
  expect_true(dir.exists(target))
})

test_that("save_plot writes a ggplot to disk and returns the path", {
  local_options(artma.verbose = 1)
  dir <- local_tempdir()
  path <- file.path(dir, "plot.png")
  plot <- ggplot2::ggplot(mtcars, ggplot2::aes(x = mpg, y = hp)) +
    ggplot2::geom_point()

  returned <- save_plot(plot, path, width = 200, height = 200)

  expect_equal(returned, path)
  expect_true(file.exists(path))
  expect_true(file.info(path)$size > 0)
})

test_that("save_plot scales resolution alongside the dimensions", {
  # Scaling the pixel dimensions alone enlarges the canvas while text keeps a
  # fixed physical size, so at graph_scale 2 every label came out half its
  # intended size relative to the plot.
  captured <- NULL
  testthat::local_mocked_bindings(
    ggsave = function(...) {
      captured <<- list(...)
      invisible(NULL)
    },
    .package = "ggplot2"
  )
  local_options(artma.verbose = 1, artma.visualization.export_html = FALSE)
  dir <- local_tempdir()
  plot <- ggplot2::ggplot(mtcars, ggplot2::aes(x = mpg, y = hp)) +
    ggplot2::geom_point()

  save_plot(plot, file.path(dir, "plot.png"), width = 400, height = 300, scale = 2, dpi = 150)

  expect_equal(captured$width, 800)
  expect_equal(captured$height, 600)
  expect_equal(captured$dpi, 300)
})

test_that("the test suite renders PNGs without ragg", {
  # Set in setup.R: ragg's font cache trips AddressSanitizer once a worker has
  # drawn text in more than 32 font configurations.
  expect_true(isTRUE(getOption(BASE_PNG_DEVICE_OPTION)))
  expect_false(use_ragg_png_device())
})

test_that("ragg is used only when installed and not switched off", {
  local_options(stats::setNames(list(FALSE), BASE_PNG_DEVICE_OPTION))
  expect_equal(use_ragg_png_device(), requireNamespace("ragg", quietly = TRUE))

  local_options(stats::setNames(list(TRUE), BASE_PNG_DEVICE_OPTION))
  expect_false(use_ragg_png_device())
})

test_that("save_plot hands ggsave the base device when ragg is switched off", {
  # Leaving `device = NULL` would not do: ggsave() picks ragg for a PNG by
  # itself whenever ragg is installed.
  captured <- NULL
  testthat::local_mocked_bindings(
    ggsave = function(...) {
      captured <<- list(...)
      invisible(NULL)
    },
    .package = "ggplot2"
  )
  local_options(
    stats::setNames(list(TRUE), BASE_PNG_DEVICE_OPTION),
    artma.verbose = 1,
    artma.visualization.export_html = FALSE
  )
  dir <- local_tempdir()
  plot <- ggplot2::ggplot(mtcars, ggplot2::aes(x = mpg, y = hp)) +
    ggplot2::geom_point()

  save_plot(plot, file.path(dir, "plot.png"), width = 400, height = 300)

  expect_identical(captured$device, base_png_device)
})

test_that("save_plot rejects non-ggplot input", {
  dir <- local_tempdir()
  expect_error(save_plot("not a plot", file.path(dir, "x.png")))
})

test_that("save_plot does not write HTML when export_html is off", {
  local_options(artma.verbose = 1, artma.visualization.export_html = FALSE)
  dir <- local_tempdir()
  path <- file.path(dir, "plot.png")
  plot <- ggplot2::ggplot(mtcars, ggplot2::aes(x = mpg, y = hp)) +
    ggplot2::geom_point()

  save_plot(plot, path, width = 200, height = 200)

  expect_false(file.exists(file.path(dir, "plot.html")))
})

test_that("save_plot additionally writes an HTML widget when export_html is on", {
  testthat::skip_if_not_installed("plotly")
  testthat::skip_if_not_installed("htmlwidgets")
  # plotly::ggplotly() and htmlwidgets::saveWidget() are mocked so this test
  # stays deterministic across plotly/ggplot2 version combinations.
  testthat::local_mocked_bindings(ggplotly = function(p, ...) list(fake_widget = TRUE), .package = "plotly")
  testthat::local_mocked_bindings(
    saveWidget = function(widget, file, ...) writeLines("<html></html>", file),
    .package = "htmlwidgets"
  )
  local_options(artma.verbose = 1, artma.visualization.export_html = TRUE)
  dir <- local_tempdir()
  path <- file.path(dir, "plot.png")
  plot <- ggplot2::ggplot(mtcars, ggplot2::aes(x = mpg, y = hp)) +
    ggplot2::geom_point()

  save_plot(plot, path, width = 200, height = 200)

  html_path <- file.path(dir, "plot.html")
  expect_true(file.exists(html_path))
  expect_true(file.info(html_path)$size > 0)
})

test_that("save_plot_html writes a standalone HTML file and returns its path", {
  testthat::skip_if_not_installed("plotly")
  testthat::skip_if_not_installed("htmlwidgets")
  testthat::local_mocked_bindings(ggplotly = function(p, ...) list(fake_widget = TRUE), .package = "plotly")
  testthat::local_mocked_bindings(
    saveWidget = function(widget, file, ...) writeLines("<html></html>", file),
    .package = "htmlwidgets"
  )
  dir <- local_tempdir()
  path <- file.path(dir, "widget.html")
  plot <- ggplot2::ggplot(mtcars, ggplot2::aes(x = mpg, y = hp)) +
    ggplot2::geom_point()

  returned <- save_plot_html(plot, path)

  expect_equal(returned, path)
  expect_true(file.exists(path))
})

test_that("save_plot_html skips with a warning when plotly or htmlwidgets are missing", {
  local_options(artma.verbose = 3)
  local_pretend_packages_absent("plotly")
  dir <- local_tempdir()
  path <- file.path(dir, "widget.html")
  plot <- ggplot2::ggplot(mtcars, ggplot2::aes(x = mpg, y = hp)) +
    ggplot2::geom_point()

  expect_message(
    result <- save_plot_html(plot, path),
    "plotly"
  )
  expect_null(result)
  expect_false(file.exists(path))
})

# options -------------------------------------------------------------------

test_that("get_visualization_options returns defaults", {
  local_options(
    artma.visualization.theme = NULL,
    artma.visualization.export_graphics = NULL,
    artma.visualization.export_html = NULL,
    artma.visualization.export_path = NULL,
    artma.visualization.graph_scale = NULL,
    artma.output.save_results = FALSE
  )

  vis <- get_visualization_options()
  expect_equal(vis$theme, "blue")
  expect_true(vis$export_graphics)
  expect_false(vis$export_html)
  expect_equal(vis$export_path, "graphics")
  expect_equal(vis$graph_scale, 2)
})

test_that("set_visualization_option updates a theme and reports the previous value", {
  local_options(
    artma.visualization.theme = "blue",
    artma.output.save_results = FALSE
  )

  previous <- set_visualization_option(theme = "red")
  expect_equal(previous$theme, "blue")
  expect_equal(getOption("artma.visualization.theme"), "red")
})

test_that("set_visualization_option updates export_html and reports the previous value", {
  local_options(
    artma.visualization.export_html = FALSE,
    artma.output.save_results = FALSE
  )

  previous <- set_visualization_option(export_html = TRUE)
  expect_false(previous$export_html)
  expect_true(getOption("artma.visualization.export_html"))
})

test_that("set_visualization_option rejects a non-logical export_html", {
  local_options(artma.output.save_results = FALSE)
  expect_error(set_visualization_option(export_html = "yes"))
})

test_that("set_visualization_option rejects an invalid theme", {
  local_options(artma.output.save_results = FALSE)
  expect_error(set_visualization_option(theme = "octarine"))
})

test_that("get_valid_themes returns the theme vector", {
  expect_equal(get_valid_themes(), c("blue", "yellow", "green", "red", "purple"))
})