tests/testthat/helper-vdiffr.R

In plotly: Create Interactive Web Graphics via 'plotly.js'

visual_testing <- grepl("true", Sys.getenv("VISUAL_TESTS"), fixed = TRUE)

message("Visual testing is ", if (!visual_testing) "not ", "enabled.")

# start up the orca image server
imageServer <- if (visual_testing) {
  # https://github.com/plotly/plotly.R/issues/2179
  reticulate::py_run_string("import sys") 
  kaleido() 
} else {
  list(transform = function(...) stop("Visual testing is disabled!"))
}


expect_doppelganger <- function(p, name, ...) {
  testthat::local_edition(3)
  
  name <- str_standardise(name)
  file <- paste0(name, ".svg")
  path <- tempfile(file, fileext = ".svg")
  testthat::announce_snapshot_file(path, name = file)
  
  if (!visual_testing) {
    return(invisible(NULL))
  }
  
  # some plots have random characteristics, so make sure we always have the same seed,
  # otherwise comparing svg produces false positives
  set.seed(555)
  
  write_plotly_svg(p, path)
  testthat::expect_snapshot_file(
    path = path, name = file, cran = FALSE,
    compare = function(old, new) {
      compare_file_text(old, new) || identical(rsvg::rsvg_png(old), rsvg::rsvg_png(new))
    }
  )
}

# run visual test and return 'built' data/layout
expect_doppelganger_built <- function(p, name, ...) {
  expect_doppelganger(p, name, ...)
  plotly_build(p)$x[c("data", "layout")]
}


# define logic for writing svg
write_plotly_svg <- function(p, file) {
  # before exporting, specify trace[i].uid so resulting svg is deterministic
  # https://github.com/plotly/orca/issues/133
  p <- plotly_build(p)
  uid_data <- paste0("-vdiffr-plotly-", seq_along(p$x$data))
  p$x$data <- Map(function(tr, id) { tr$uid <- id; tr }, p$x$data, uid_data)
  
  # write svg to disk
  owd <- setwd(dirname(file))
  on.exit(setwd(owd))
  imageServer$transform(p, file = basename(file), width = 640, height = 480)
  
  # strip out non-deterministic fullLayout.uid
  # TODO: if and when plotly provides an API to pre-specify, use it!
  svg_txt <- readLines(file, warn = FALSE)
  strextract <- function(str, pattern) regmatches(str, regexpr(pattern, str))
  def <- strextract(svg_txt, 'defs id=\\"defs-[[:alnum:]]+\\"')
  uid <- sub("defs-", "", strextract(def, "defs-[[:alnum:]]+"))
  svg_txt <- gsub(uid, "", svg_txt, fixed = TRUE)
  writeLines(svg_txt, file)
}

# copied from vdiffr
str_standardise <- function(s, sep = "-") {
  stopifnot(rlang::is_scalar_character(s))
  s <- gsub("[^a-z0-9]", sep, tolower(s))
  s <- gsub(paste0(sep, sep, "+"), sep, s)
  s <- gsub(paste0("^", sep, "|", sep, "$"), "", s)
  s
}