Custom snapshot expectation

expect_snapshot.R

is_ci <- function() {
  isTRUE(as.logical(Sys.getenv("CI")))
}

make_variant <- function(
    platform = shinytest2::platform_variant(),
    data_version = getOption("test_data_version", "simulated")) {
  ci <- if (is_ci()) {
    "ci"
  } else {
    NULL
  }
  paste(c(ci, platform, data_version), collapse = "-")
}

expect_snapshot <- function(
    x,
    name,
    variant = getOption("test_variant", make_variant()),
    threshold = getOption("test_snapshot_threshold", 0)) {
  UseMethod("expect_snapshot")
}

expect_snapshot.shiny.tag.list <- function(
    x,
    name,
    variant = getOption("test_variant", make_variant()),
    threshold = getOption("test_snapshot_threshold", 0)) {
  html_temp <- fs::path(tempdir(), name, ext = "html")
  png_temp <- fs::path(tempdir(), name, ext = "png")
  on.exit(unlink(tempdir()))
  png_path <- fs::path(name, ext = "png")
  htmltools::save_html(x, file = html_temp)
  webshot2::webshot(url = html_temp, file = png_temp, delay = 0.5, quiet = TRUE, expand = 100)

  testthat::expect_snapshot_file(
    png_temp,
    name = png_path,
    compare = function(old, new) {
      try(silent = TRUE, {
        diff <- shinytest2::screenshot_max_difference(old, new)
        if (diff > 0) {
          cli::cli_bullets(
            c(
              "!" = "Difference between new and old snapshot is {round(diff, digits = 2)}.",
              "i" = "To allow this difference to pass tests set `threshold` to number higher than the difference."
            )
          )
        }
      })
      shinytest2::compare_screenshot_threshold(old, new, threshold = threshold, quiet = TRUE)
    },
    variant = variant
  )
}

expect_snapshot.shiny.tag <- expect_snapshot.shiny.tag.list
expect_snapshot.htmlwidget <- expect_snapshot.shiny.tag.list

expect_snapshot.data.frame <- function(
    x,
    name,
    variant = getOption("test_variant", make_variant()),
    threshold = getOption("test_snapshot_threshold", 0)) {
  csv_temp <- fs::path(tempdir(), name, ext = "csv")
  on.exit(unlink(tempdir()))
  csv_path <- fs::path(name, ext = "csv")
  readr::write_csv(x, csv_temp)
  testthat::expect_snapshot_file(
    csv_temp,
    name = csv_path,
    variant = variant
  )
}