From 0e95e0b3d504d7ba0cd45d668afdce2d68602a49 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= <38475991+FBartos@users.noreply.github.com> Date: Fri, 29 May 2026 08:22:03 +0200 Subject: [PATCH 1/2] Fix plot fallback snapshots --- R/testthat-helper-plots.R | 211 ++++++++++++++++-- man/expect_equal_plots.Rd | 20 +- .../test-expect-equal-plots-fallback.R | 171 +++++++++++++- 3 files changed, 375 insertions(+), 27 deletions(-) diff --git a/R/testthat-helper-plots.R b/R/testthat-helper-plots.R index 2e86e01..c7173ba 100644 --- a/R/testthat-helper-plots.R +++ b/R/testthat-helper-plots.R @@ -4,11 +4,17 @@ #' If no visual reference (.svg) exists yet, \pkg{vdiffr} handles it like other visual snapshots. #' #' For \pkg{ggplot2} objects, a structural fallback snapshot is also maintained. -#' In interactive test runs, if that structural snapshot is missing, it is created automatically -#' (even when the visual comparison passes). +#' When a visual comparison passes, missing structural snapshots are created in +#' interactive test runs, in update mode (\code{options(jaspTools.plotStructure.update = TRUE)} +#' or \code{JASP_PLOT_STRUCTURE_UPDATE=true}), and for newly generated visual snapshots. +#' They are not created after a visual mismatch against an existing visual snapshot. #' -#' To accept changed structural snapshots, use \code{testthat::snapshot_accept()} from the -#' package root after running tests. +#' If a visual mismatch is accepted by the structural fallback, inspect and accept +#' the generated visual snapshot with \code{manageTestPlots()} so future runs do +#' not keep using the slower fallback. +#' Plot snapshot rendering triggers garbage collection by default to avoid +#' accumulated \pkg{ggplot2} build state slowing large generated test files; set +#' \code{options(jaspTools.plotSnapshot.gc = FALSE)} to disable this. #' #' #' @param test The plot object you wish to test (does not work well for non-ggplot2 objects). @@ -56,17 +62,25 @@ expect_equal_plots <- function(test, name, dir = lifecycle::deprecated(), tolera expect_plot_with_fallback <- function(name, test, tolerance = NULL) { result <- capture_vdiffr_expectation(name, test) + freshVisual <- is_fresh_visual_snapshot(result) + if (isTRUE(result$passed)) { - maybe_seed_ggplot_structure_snapshot(test, name) + maybe_seed_ggplot_structure_snapshot(test, name, force = freshVisual) return(invisible(TRUE)) } + if (freshVisual) + maybe_seed_ggplot_structure_snapshot(test, name, force = TRUE) + # Save the CI-generated SVG so it can be uploaded as an artifact for comparison - save_failed_plot_svg(test, name) + save_failed_plot_svg(test, name, vdiffr_result = result) + + if (freshVisual) + fail_fresh_visual_snapshot(name, result) fallbackResult <- expect_doppelganger_fallback(test, name, vdiffr_result = result, tolerance = tolerance) if (isTRUE(fallbackResult$passed)) { - warning("vdiffr mismatch for '", name, "' accepted by structural fallback.", call. = FALSE) + warning(build_structural_fallback_review_message(name, result), call. = FALSE) testthat::succeed(paste0("vdiffr mismatch for '", name, "' accepted by fallback.")) return(invisible(TRUE)) } @@ -82,6 +96,21 @@ expect_plot_with_fallback <- function(name, test, tolerance = NULL) { invisible(FALSE) } +fail_fresh_visual_snapshot <- function(name, vdiffr_result) { + vdiffrMsg <- if (!is.null(vdiffr_result$exception)) + conditionMessage(vdiffr_result$exception) + else + "" + + testthat::fail(paste0( + "vdiffr created a new visual snapshot for '", + name, + "'. Review and accept the visual snapshot before structural fallback can be used. ", + "Original vdiffr failure: ", + vdiffrMsg + )) +} + build_fallback_failure_message <- function(fallbackResult) { fallbackMsg <- fallbackResult$message @@ -108,7 +137,7 @@ build_fallback_failure_message <- function(fallbackResult) { combinedFallbackMsg } -maybe_seed_ggplot_structure_snapshot <- function(test, name) { +maybe_seed_ggplot_structure_snapshot <- function(test, name, force = FALSE) { if (!is_ggplot(test)) return(invisible(FALSE)) @@ -116,17 +145,18 @@ maybe_seed_ggplot_structure_snapshot <- function(test, name) { snapshotName <- ggplot_structure_snapshot_name(name) snapshotPath <- snapshot_relative_path(snapshotName) - ensure_snapshot_subdir(snapshotName) - testthat::announce_snapshot_file(path = snapshotPath, name = snapshotName) updateMode <- should_update_ggplot_structure_snapshots() if (!updateMode && file.exists(snapshotPath)) return(invisible(FALSE)) - if (!updateMode && !is_interactive_plot_snapshot_mode()) + if (!updateMode && !isTRUE(force) && !is_interactive_plot_snapshot_mode()) return(invisible(FALSE)) + ensure_snapshot_subdir(snapshotName) + testthat::announce_snapshot_file(path = snapshotPath, name = snapshotName) + writeRes <- write_ggplot_structure_snapshot(test, snapshotName, snapshotPath, overwrite = updateMode) if (!isTRUE(writeRes$passed)) return(invisible(FALSE)) @@ -141,42 +171,113 @@ maybe_seed_ggplot_structure_snapshot <- function(test, name) { } capture_vdiffr_expectation <- function(name, test) { - out <- list(passed = FALSE, exception = NULL) + maybe_collect_plot_snapshot_garbage() + + svgName <- paste0(str_standardise_snapshot_name(name), ".svg") + newSvgName <- paste0(str_standardise_snapshot_name(name), ".new.svg") + svgPath <- snapshot_relative_path(svgName) + newSvgPath <- snapshot_relative_path(newSvgName) + newSvgBefore <- snapshot_file_state(newSvgPath) + + out <- list( + passed = FALSE, + exception = NULL, + svg_path = svgPath, + new_svg_path = newSvgPath, + reference_existed = file.exists(svgPath), + new_svg_current = FALSE + ) tryCatch( { suppressWarnings(vdiffr::expect_doppelganger(name, test)) out$passed <- TRUE + out <- update_vdiffr_result_paths(out, newSvgBefore) # In interactive mode, vdiffr silently accepts mismatches by writing a # .new.svg file. Detect this and treat it as a mismatch. - newSvgName <- paste0(str_standardise_snapshot_name(name), ".new.svg") - newSvgPath <- snapshot_relative_path(newSvgName) - if (file.exists(newSvgPath)) { + if (isTRUE(out$new_svg_current)) { out$passed <- FALSE out$exception <- simpleError(paste0( "vdiffr mismatch for '", name, "' (detected via .new.svg in interactive mode)." )) - unlink(newSvgPath) } out }, expectation_failure = function(cnd) { out$exception <- cnd + out <- update_vdiffr_result_paths(out, newSvgBefore) out }, expectation_warning = function(cnd) { out$exception <- cnd + out <- update_vdiffr_result_paths(out, newSvgBefore) out }, error = function(cnd) { out$exception <- cnd + out <- update_vdiffr_result_paths(out, newSvgBefore) out } ) } +maybe_collect_plot_snapshot_garbage <- function() { + if (isFALSE(getOption("jaspTools.plotSnapshot.gc", TRUE))) + return(invisible(FALSE)) + + invisible(gc(FALSE)) +} + +update_vdiffr_result_paths <- function(result, newSvgBefore) { + result$new_svg_current <- snapshot_file_changed(newSvgBefore, result$new_svg_path) + result +} + +snapshot_file_state <- function(path) { + if (!file.exists(path)) + return(list(exists = FALSE, size = NA_real_, mtime = as.POSIXct(NA), bytes = NULL)) + + info <- file.info(path) + size <- info$size + bytes <- tryCatch(readBin(path, what = "raw", n = size), error = function(cnd) NULL) + + list( + exists = TRUE, + size = size, + mtime = info$mtime, + bytes = bytes + ) +} + +snapshot_file_changed <- function(before, path) { + after <- snapshot_file_state(path) + + if (!isTRUE(after$exists)) + return(FALSE) + if (!isTRUE(before$exists)) + return(TRUE) + if (!identical(before$size, after$size)) + return(TRUE) + if (!identical(before$mtime, after$mtime)) + return(TRUE) + if (!identical(before$bytes, after$bytes)) + return(TRUE) + + FALSE +} + +is_visual_failure_result <- function(vdiffr_result) { + !is.null(vdiffr_result) && !isTRUE(vdiffr_result$passed) +} + +is_fresh_visual_snapshot <- function(vdiffr_result) { + !is.null(vdiffr_result) && + !isTRUE(vdiffr_result$reference_existed) && + (file.exists(vdiffr_result$svg_path) || isTRUE(vdiffr_result$new_svg_current)) +} + #' @noRd expect_doppelganger_fallback <- function(test, name, ..., tolerance = NULL) { if (is.function(test)) @@ -217,12 +318,28 @@ expect_doppelganger_fallback.ggplot <- function(test, name, vdiffr_result = NULL expect_equal_ggplot_structure <- function(plot, name, vdiffr_result = NULL, tolerance = NULL) { testthat::local_edition(3) + clear_last_structural_diff() if (!is.null(tolerance)) withr::local_options(jaspTools.plotStructure.tolerance = tolerance) snapshotName <- ggplot_structure_snapshot_name(name) snapshotPath <- snapshot_relative_path(snapshotName) + visualFailure <- is_visual_failure_result(vdiffr_result) + + if (visualFailure && !file.exists(snapshotPath)) { + return(list( + passed = FALSE, + has_fallback = TRUE, + exception = NULL, + message = paste0( + "No ggplot structural snapshot exists for '", + name, + "'. Not creating one because the visual comparison failed." + ) + )) + } + ensure_snapshot_subdir(snapshotName) testthat::announce_snapshot_file(path = snapshotPath, name = snapshotName) @@ -238,9 +355,9 @@ expect_equal_ggplot_structure <- function(plot, name, vdiffr_result = NULL, tole tmpPath <- buildRes$tmpPath - if (should_update_ggplot_structure_snapshots()) { + if (!visualFailure && should_update_ggplot_structure_snapshots()) { hadSnapshot <- file.exists(snapshotPath) - writeRes <- write_ggplot_structure_snapshot(plot, snapshotName, snapshotPath, overwrite = TRUE) + writeRes <- write_ggplot_structure_snapshot(plot, snapshotName, snapshotPath, overwrite = TRUE, buildRes = buildRes) if (!isTRUE(writeRes$passed)) return(writeRes) @@ -259,6 +376,20 @@ expect_equal_ggplot_structure <- function(plot, name, vdiffr_result = NULL, tole )) } + if (visualFailure) { + passed <- compare_ggplot_structure_snapshot(snapshotPath, tmpPath) + return(list( + passed = isTRUE(passed), + has_fallback = TRUE, + exception = NULL, + message = if (isTRUE(passed)) { + paste0("vdiffr mismatch for '", name, "' accepted by ggplot structural fallback.") + } else { + paste0("ggplot structural snapshot for '", name, "' failed.") + } + )) + } + snapshotRes <- tryCatch( { testthat::expect_snapshot_file( @@ -329,9 +460,11 @@ build_ggplot_structure_snapshot <- function(plot) { ) } -write_ggplot_structure_snapshot <- function(plot, snapshotName, snapshotPath, overwrite = FALSE) { +write_ggplot_structure_snapshot <- function(plot, snapshotName, snapshotPath, overwrite = FALSE, buildRes = NULL) { ensure_snapshot_subdir(snapshotName) - buildRes <- build_ggplot_structure_snapshot(plot) + if (is.null(buildRes)) + buildRes <- build_ggplot_structure_snapshot(plot) + if (!isTRUE(buildRes$passed)) { return(list( passed = FALSE, @@ -399,26 +532,51 @@ is_ggplot <- function(x) { # Save the plot as SVG in the _snaps folder when vdiffr fails. # This allows CI to upload the generated SVG as an artifact for visual comparison. -save_failed_plot_svg <- function(test, name) { +save_failed_plot_svg <- function(test, name, vdiffr_result = NULL) { tryCatch({ newSvgName <- paste0(str_standardise_snapshot_name(name), ".new.svg") - svgPath <- snapshot_relative_path(newSvgName) + svgPath <- if (!is.null(vdiffr_result) && !is.null(vdiffr_result$new_svg_path)) + vdiffr_result$new_svg_path + else + snapshot_relative_path(newSvgName) + + if (isTRUE(vdiffr_result$new_svg_current) && file.exists(svgPath)) + return(invisible(svgPath)) + ensure_snapshot_subdir(newSvgName) if (is_ggplot(test)) { svglite::svglite(svgPath, width = 7, height = 5) print(test) - dev.off() + grDevices::dev.off() } else if (is.function(test)) { svglite::svglite(svgPath, width = 7, height = 5) test() - dev.off() + grDevices::dev.off() } }, error = function(e) { # silently ignore — saving is best-effort }) } +build_structural_fallback_review_message <- function(name, vdiffr_result = NULL) { + newSvgPath <- if (!is.null(vdiffr_result)) vdiffr_result$new_svg_path else NULL + reviewPath <- if (!is.null(newSvgPath) && file.exists(newSvgPath)) + newSvgPath + else + "" + + paste0( + "vdiffr mismatch for '", + name, + "' accepted by structural fallback. Review the visual change at ", + reviewPath, + " and accept the visual snapshot with jaspTools::manageTestPlots() or ", + "testthat::snapshot_review(). Until the visual snapshot is accepted, ", + "future runs will keep using the slower structural fallback." + ) +} + # Environment to store the last structural comparison details, so they can be # retrieved and included in failure messages (message() output is lost on CI). .structuralDiffEnv <- new.env(parent = emptyenv()) @@ -475,6 +633,11 @@ get_last_structural_diff <- function() { .structuralDiffEnv$lastDiff } +clear_last_structural_diff <- function() { + .structuralDiffEnv$lastDiff <- NULL + invisible(NULL) +} + get_snapshotter <- function() { x <- getOption("testthat.snapshotter") if (is.null(x)) diff --git a/man/expect_equal_plots.Rd b/man/expect_equal_plots.Rd index eac8d4e..2356de1 100644 --- a/man/expect_equal_plots.Rd +++ b/man/expect_equal_plots.Rd @@ -13,11 +13,27 @@ expect_equal_plots(test, name, dir = lifecycle::deprecated(), tolerance = NULL) \item{dir}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} -\item{tolerance}{Optional numeric tolerance for the structural fallback comparison (default \code{1e-6}). Set to a larger value (e.g. \code{1e-3}) for plots whose data vary across platforms (e.g. MCMC-based Bayesian plots).} +\item{tolerance}{Optional numeric tolerance for the structural fallback +comparison (default \code{1e-6}). Set to a larger value (e.g. \code{1e-3}) +for plots whose data vary across platforms (e.g. MCMC-based Bayesian plots).} } \description{ This function compares a stored .svg of a plot, to the plot that is created when the tests are run. -If no .svg exists yet then you must first run \code{manageTestPlots}. +If no visual reference (.svg) exists yet, \pkg{vdiffr} handles it like other visual snapshots. +} +\details{ +For \pkg{ggplot2} objects, a structural fallback snapshot is also maintained. +When a visual comparison passes, missing structural snapshots are created in +interactive test runs, in update mode (\code{options(jaspTools.plotStructure.update = TRUE)} +or \code{JASP_PLOT_STRUCTURE_UPDATE=true}), and for newly generated visual snapshots. +They are not created after a visual mismatch against an existing visual snapshot. + +If a visual mismatch is accepted by the structural fallback, inspect and accept +the generated visual snapshot with \code{manageTestPlots()} so future runs do +not keep using the slower fallback. +Plot snapshot rendering triggers garbage collection by default to avoid +accumulated \pkg{ggplot2} build state slowing large generated test files; set +\code{options(jaspTools.plotSnapshot.gc = FALSE)} to disable this. } \examples{ diff --git a/tests/testthat/test-expect-equal-plots-fallback.R b/tests/testthat/test-expect-equal-plots-fallback.R index eed0a75..194b7f9 100644 --- a/tests/testthat/test-expect-equal-plots-fallback.R +++ b/tests/testthat/test-expect-equal-plots-fallback.R @@ -7,6 +7,21 @@ makeExpectationFailure <- function(msg = "vdiffr mismatch") { ) } +localPlotSnapshotRoot <- function(root = tempfile("plot-snapshot-root-")) { + dir.create(root, recursive = TRUE, showWarnings = FALSE) + + env <- parent.frame() + testthat::local_mocked_bindings( + snapshot_relative_path = function(name) { + file.path(root, name) + }, + .package = "jaspTools", + .env = env + ) + + invisible(root) +} + test_that("vdiffr mismatch falls back to ggplot structural snapshot", { skip_if_not_installed("ggplot2") @@ -17,9 +32,12 @@ test_that("vdiffr mismatch falls back to ggplot structural snapshot", { p <- ggplot2::ggplot(mtcars, ggplot2::aes(wt, mpg)) + ggplot2::geom_point() - snapshotPath <- jaspTools:::ggplot_structure_snapshot_path("demo-plot") + snapshotRoot <- tempfile("plot-snapshot-root-") + snapshotName <- jaspTools:::ggplot_structure_snapshot_name("demo-plot") + snapshotPath <- file.path(snapshotRoot, snapshotName) dir.create(dirname(snapshotPath), recursive = TRUE, showWarnings = FALSE) saveRDS(jaspTools:::extract_ggplot_structure(p), snapshotPath) + localPlotSnapshotRoot(snapshotRoot) testthat::local_mocked_bindings( expect_doppelganger = function(...) { @@ -64,6 +82,7 @@ test_that("update mode writes ggplot structural snapshot when missing", { dir.create(tmp, recursive = TRUE, showWarnings = FALSE) oldWd <- setwd(tmp) on.exit(setwd(oldWd), add = TRUE) + localPlotSnapshotRoot() p <- ggplot2::ggplot(mtcars, ggplot2::aes(disp, hp)) + ggplot2::geom_point() @@ -79,6 +98,7 @@ test_that("interactive run seeds missing ggplot structural snapshot", { dir.create(tmp, recursive = TRUE, showWarnings = FALSE) oldWd <- setwd(tmp) on.exit(setwd(oldWd), add = TRUE) + localPlotSnapshotRoot() p <- ggplot2::ggplot(mtcars, ggplot2::aes(wt, mpg)) + ggplot2::geom_point() snapshotPath <- jaspTools:::ggplot_structure_snapshot_path("seed-plot") @@ -101,6 +121,155 @@ test_that("interactive run seeds missing ggplot structural snapshot", { expect_true(file.exists(snapshotPath)) }) +test_that("fresh visual snapshot seeds structure but still requires review", { + skip_if_not_installed("ggplot2") + localPlotSnapshotRoot() + + p <- ggplot2::ggplot(mtcars, ggplot2::aes(wt, mpg)) + ggplot2::geom_point() + newSvgPath <- jaspTools:::snapshot_relative_path("fresh-plot.new.svg") + snapshotPath <- jaspTools:::ggplot_structure_snapshot_path("fresh-plot") + + testthat::local_mocked_bindings( + expect_doppelganger = function(...) { + dir.create(dirname(newSvgPath), recursive = TRUE, showWarnings = FALSE) + writeLines("fresh", newSvgPath) + invisible(NULL) + }, + .package = "vdiffr" + ) + + failure <- tryCatch( + { + jaspTools:::expect_plot_with_fallback("fresh-plot", p) + NULL + }, + expectation_failure = function(cnd) cnd + ) + + expect_s3_class(failure, "expectation_failure") + expect_match(conditionMessage(failure), "created a new visual snapshot", fixed = TRUE) + expect_true(file.exists(snapshotPath)) +}) + +test_that("visual mismatch with structural pass reports current new svg", { + skip_if_not_installed("ggplot2") + localPlotSnapshotRoot() + + p <- ggplot2::ggplot(mtcars, ggplot2::aes(wt, mpg)) + ggplot2::geom_point() + svgPath <- jaspTools:::snapshot_relative_path("review-plot.svg") + newSvgPath <- jaspTools:::snapshot_relative_path("review-plot.new.svg") + snapshotPath <- jaspTools:::ggplot_structure_snapshot_path("review-plot") + dir.create(dirname(svgPath), recursive = TRUE, showWarnings = FALSE) + dir.create(dirname(snapshotPath), recursive = TRUE, showWarnings = FALSE) + writeLines("old", svgPath) + saveRDS(jaspTools:::extract_ggplot_structure(p), snapshotPath) + + testthat::local_mocked_bindings( + expect_doppelganger = function(...) { + writeLines("current", newSvgPath) + invisible(NULL) + }, + .package = "vdiffr" + ) + + expect_warning( + jaspTools:::expect_plot_with_fallback("review-plot", p), + "Review the visual change" + ) + expect_true(file.exists(newSvgPath)) +}) + +test_that("stale new svg is ignored when vdiffr passes", { + skip_if_not_installed("ggplot2") + localPlotSnapshotRoot() + + p <- ggplot2::ggplot(mtcars, ggplot2::aes(wt, mpg)) + ggplot2::geom_point() + newSvgPath <- jaspTools:::snapshot_relative_path("stale-plot.new.svg") + dir.create(dirname(newSvgPath), recursive = TRUE, showWarnings = FALSE) + writeLines("", newSvgPath) + + testthat::local_mocked_bindings( + expect_doppelganger = function(...) { + invisible(NULL) + }, + .package = "vdiffr" + ) + + result <- jaspTools:::capture_vdiffr_expectation("stale-plot", p) + expect_true(result$passed) + expect_false(result$new_svg_current) + expect_true(file.exists(newSvgPath)) +}) + +test_that("visual failure with missing structural snapshot does not create fallback", { + skip_if_not_installed("ggplot2") + oldOpts <- options(jaspTools.plotStructure.update = TRUE) + on.exit(options(oldOpts), add = TRUE) + localPlotSnapshotRoot() + + p <- ggplot2::ggplot(mtcars, ggplot2::aes(wt, mpg)) + ggplot2::geom_point() + snapshotPath <- jaspTools:::ggplot_structure_snapshot_path("missing-plot") + vdiffrResult <- list(passed = FALSE, exception = makeExpectationFailure()) + + fallbackResult <- jaspTools:::expect_equal_ggplot_structure(p, "missing-plot", vdiffr_result = vdiffrResult) + + expect_false(fallbackResult$passed) + expect_true(fallbackResult$has_fallback) + expect_false(file.exists(snapshotPath)) + expect_match(fallbackResult$message, "Not creating one because the visual comparison failed", fixed = TRUE) +}) + +test_that("stale new svg is overwritten after visual failure", { + skip_if_not_installed("ggplot2") + skip_if_not_installed("svglite") + localPlotSnapshotRoot() + + p <- ggplot2::ggplot(mtcars, ggplot2::aes(wt, mpg)) + ggplot2::geom_point() + svgPath <- jaspTools:::snapshot_relative_path("stale-failure-plot.svg") + newSvgPath <- jaspTools:::snapshot_relative_path("stale-failure-plot.new.svg") + snapshotPath <- jaspTools:::ggplot_structure_snapshot_path("stale-failure-plot") + dir.create(dirname(svgPath), recursive = TRUE, showWarnings = FALSE) + dir.create(dirname(snapshotPath), recursive = TRUE, showWarnings = FALSE) + writeLines("old", svgPath) + writeLines("stale", newSvgPath) + saveRDS(jaspTools:::extract_ggplot_structure(p), snapshotPath) + + testthat::local_mocked_bindings( + expect_doppelganger = function(...) { + stop(makeExpectationFailure(), call. = FALSE) + }, + .package = "vdiffr" + ) + + expect_warning( + jaspTools:::expect_plot_with_fallback("stale-failure-plot", p), + "Review the visual change" + ) + expect_false(any(grepl("stale", readLines(newSvgPath, warn = FALSE), fixed = TRUE))) +}) + +test_that("update mode does not overwrite structural snapshot after visual failure", { + skip_if_not_installed("ggplot2") + oldOpts <- options(jaspTools.plotStructure.update = TRUE) + on.exit(options(oldOpts), add = TRUE) + localPlotSnapshotRoot() + + p1 <- ggplot2::ggplot(mtcars, ggplot2::aes(wt, mpg)) + ggplot2::geom_point() + p2 <- ggplot2::ggplot(mtcars, ggplot2::aes(wt, mpg)) + ggplot2::geom_point(colour = "red") + snapshotName <- jaspTools:::ggplot_structure_snapshot_name("locked-plot") + snapshotPath <- jaspTools:::snapshot_relative_path(snapshotName) + dir.create(dirname(snapshotPath), recursive = TRUE, showWarnings = FALSE) + saveRDS(jaspTools:::extract_ggplot_structure(p1), snapshotPath) + original <- readBin(snapshotPath, what = "raw", n = file.info(snapshotPath)$size) + vdiffrResult <- list(passed = FALSE, exception = makeExpectationFailure()) + + fallbackResult <- jaspTools:::expect_equal_ggplot_structure(p2, "locked-plot", vdiffr_result = vdiffrResult) + current <- readBin(snapshotPath, what = "raw", n = file.info(snapshotPath)$size) + + expect_false(fallbackResult$passed) + expect_identical(current, original) +}) + test_that("compare_ggplot_structure_snapshot returns TRUE only for equal structures", { skip_if_not_installed("ggplot2") From acb89d1c57db3a3644b623d3b3504783c3e0ec92 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Fri, 29 May 2026 15:17:32 +0200 Subject: [PATCH 2/2] Keep fast replay plots decoded --- R/run.R | 64 +++++++++++++++- R/view.R | 3 + .../test-runAnalysis-fast-test-plots.R | 76 +++++++++++++++++++ tests/testthat/test-view.R | 28 +++++++ 4 files changed, 169 insertions(+), 2 deletions(-) create mode 100644 tests/testthat/test-runAnalysis-fast-test-plots.R create mode 100644 tests/testthat/test-view.R diff --git a/R/run.R b/R/run.R index 6cc31c2..6858df9 100644 --- a/R/run.R +++ b/R/run.R @@ -68,7 +68,8 @@ runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = FALS stop("Please supply an analysis name") } - if (insideTestEnvironment()) { + testing <- insideTestEnvironment() + if (testing) { view <- FALSE quiet <- TRUE } @@ -83,6 +84,11 @@ runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = FALS Sys.setenv(LANGUAGE = oldLanguage) }, add = TRUE) + if (testing) { + restorePlotRendering <- useFastTestPlotImages() + on.exit(restorePlotRendering(), add = TRUE) + } + initAnalysisRuntime(dataset = dataset, options = options, makeTests = makeTests, encodedDataset = encodedDataset) args <- fetchRunArgs(name, options) @@ -106,7 +112,7 @@ runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = FALS results <- processJsonResults(jsonResults) - if (insideTestEnvironment()) + if (testing) .setInternal("lastResults", jsonResults) if (view) @@ -118,6 +124,60 @@ runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = FALS return(invisible(results)) } +useFastTestPlotImages <- function() { + noop <- function() invisible(FALSE) + + if (isFALSE(getOption("jaspTools.test.skipPlotRendering", TRUE))) + return(noop) + + ns <- asNamespace("jaspBase") + fnName <- "writeImageJaspResults" + if (!exists(fnName, envir = ns, inherits = FALSE)) + return(noop) + + original <- get(fnName, envir = ns) + if (isTRUE(attr(original, "jaspToolsFastTestPlotImages"))) + return(noop) + + fastWriteImageJaspResults <- function(plot, width = 320, height = 320, obj = TRUE, + relativePathpng = NULL, relativePathJson = NULL, + ppi = 300, backgroundColor = "white", + location = jaspBase:::getImageLocation(), + oldPlotInfo = list()) { + if (is.null(relativePathpng)) + relativePathpng <- location$relativePath + + image <- list( + png = relativePathpng, + editOptions = "{}", + interactive = FALSE + ) + + if (isTRUE(obj)) { + decodePlot <- get0(".decodeJaspPlotObject", envir = ns, inherits = FALSE) + image[["obj"]] <- if (is.function(decodePlot)) { + decodePlot(plot, returnGrob = FALSE) + } else { + plot + } + } + + image + } + attr(fastWriteImageJaspResults, "jaspToolsFastTestPlotImages") <- TRUE + + unlockBinding(fnName, ns) + assign(fnName, fastWriteImageJaspResults, envir = ns) + lockBinding(fnName, ns) + + function() { + unlockBinding(fnName, ns) + assign(fnName, original, envir = ns) + lockBinding(fnName, ns) + invisible(TRUE) + } +} + fetchRunArgs <- function(name, options) { possibleArgs <- list( name = name, diff --git a/R/view.R b/R/view.R index 146571b..0f5f203 100644 --- a/R/view.R +++ b/R/view.R @@ -195,6 +195,9 @@ createHtmlFile <- function(json) { } moveJaspHtmlToDir <- function(dir) { + if (!dir.exists(dir)) + dir.create(dir, recursive = TRUE) + if (!"js" %in% list.dirs(dir, full.names = FALSE)) file.copy(list.files(getPkgOption("html.dir"), full.names = TRUE), dir, recursive = TRUE) } diff --git a/tests/testthat/test-runAnalysis-fast-test-plots.R b/tests/testthat/test-runAnalysis-fast-test-plots.R new file mode 100644 index 0000000..222a97b --- /dev/null +++ b/tests/testthat/test-runAnalysis-fast-test-plots.R @@ -0,0 +1,76 @@ +context("runAnalysis fast test plots") + +test_that("test plot image writer preserves objects without rendering", { + skip_if_not_installed("jaspBase") + + ns <- asNamespace("jaspBase") + original <- get("writeImageJaspResults", envir = ns) + + restore <- jaspTools:::useFastTestPlotImages() + on.exit(restore(), add = TRUE) + + fast <- get("writeImageJaspResults", envir = ns) + expect_true(isTRUE(attr(fast, "jaspToolsFastTestPlotImages"))) + + plot <- structure(list(x = 1), class = "unit-test-plot") + image <- fast( + plot = plot, + obj = TRUE, + location = list(root = tempdir(), relativePath = "test-fast-plot.png") + ) + + expect_identical(image[["png"]], "test-fast-plot.png") + expect_identical(image[["obj"]], plot) + expect_false(file.exists(file.path(tempdir(), "test-fast-plot.png"))) + + restore() + expect_identical(get("writeImageJaspResults", envir = ns), original) +}) + +test_that("test plot image writer stores decoded objects", { + skip_if_not_installed("jaspBase") + skip_if_not_installed("ggplot2") + + ns <- asNamespace("jaspBase") + skip_if_not(exists(".decodeJaspPlotObject", envir = ns, inherits = FALSE)) + + oldDecoder <- if (exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE)) { + get(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE) + } else { + NULL + } + hadDecoder <- exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE) + on.exit({ + if (hadDecoder) { + assign(".decodeColNamesLax", oldDecoder, envir = .GlobalEnv) + } else if (exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE)) { + rm(".decodeColNamesLax", envir = .GlobalEnv) + } + }, add = TRUE) + + assign( + ".decodeColNamesLax", + function(x) gsub("JaspColumn_1_Encoded", "group", x, fixed = TRUE), + envir = .GlobalEnv + ) + + restore <- jaspTools:::useFastTestPlotImages() + on.exit(restore(), add = TRUE) + + plot <- ggplot2::ggplot( + data.frame(x = 1, y = 2), + ggplot2::aes(x = x, y = y) + ) + + ggplot2::geom_point() + + ggplot2::labs(x = "JaspColumn_1_Encoded") + + fast <- get("writeImageJaspResults", envir = ns) + image <- fast( + plot = plot, + obj = TRUE, + location = list(root = tempdir(), relativePath = "test-fast-decoded-plot.png") + ) + + expect_identical(unname(image[["obj"]]$labels$x), "group") + expect_false(file.exists(file.path(tempdir(), "test-fast-decoded-plot.png"))) +}) diff --git a/tests/testthat/test-view.R b/tests/testthat/test-view.R new file mode 100644 index 0000000..bdd5f82 --- /dev/null +++ b/tests/testthat/test-view.R @@ -0,0 +1,28 @@ +context("view helpers") + +test_that("html assets are copied into a fresh output directory", { + sourceDir <- tempfile("jaspTools-html-src-") + dir.create(file.path(sourceDir, "js"), recursive = TRUE) + writeLines("", file.path(sourceDir, "index-jasp.html")) + writeLines("window.analysisChanged = function() {};", file.path(sourceDir, "js", "analysis.js")) + + oldJaspToolsPath <- .getInternal("jaspToolsPath") + oldHtmlDir <- .pkgenv[["pkgOptions"]][["html.dir"]] + tempJaspToolsPath <- tempfile("jaspTools-path-") + dir.create(tempJaspToolsPath, recursive = TRUE) + file.create(file.path(tempJaspToolsPath, "setup_complete.txt")) + on.exit({ + .setInternal("jaspToolsPath", oldJaspToolsPath) + .pkgenv[["pkgOptions"]][["html.dir"]] <- oldHtmlDir + }, add = TRUE) + .setInternal("jaspToolsPath", tempJaspToolsPath) + .pkgenv[["pkgOptions"]][["html.dir"]] <- sourceDir + + outputDir <- tempfile("jaspTools-html-out-") + expect_false(dir.exists(outputDir)) + + moveJaspHtmlToDir(outputDir) + + expect_true(file.exists(file.path(outputDir, "index-jasp.html"))) + expect_true(file.exists(file.path(outputDir, "js", "analysis.js"))) +})