Improve case construction

And use `case` as suffix

Author: lionel-

R/cases-ui.R

@@ -8,7 +8,7 @@
 #' @export
 manage_cases <- function(package = ".", filter = NULL) {
   cases <- collect_cases(package, filter = filter)
-  cases <- filter_cases(cases, c("case_new", "case_mismatch", "case_orphaned"))
+  cases <- filter_cases(cases, c("new_case", "mismatch_case", "orphaned_case"))
 
   vdiffrApp <- shiny::shinyApp(
     ui = vdiffrUi(cases),
@@ -27,7 +27,7 @@ manage_cases <- function(package = ".", filter = NULL) {
 vdiffrAddin <- function() {
   pkg_path <- rstudioapi::getActiveProject() %||% "."
   cases <- collect_cases(pkg_path)
-  cases <- filter_cases(cases, c("case_new", "case_mismatch", "case_orphaned"))
+  cases <- filter_cases(cases, c("new_case", "mismatch_case", "orphaned_case"))
 
   vdiffrApp <- shiny::shinyApp(
     ui = vdiffrUi(cases),

R/cases.R

@@ -55,27 +55,32 @@ orphaned_cases <- function(cases) {
   orphans_paths <- svg_paths[is_orphan]
   orphans_names <- map_chr(orphans_paths, ~str_trim_ext(basename(.x)))
 
-  args <- list(set_names(orphans_names), orphans_paths, orphans_testcases)
-  orphaned_cases <- purrr::pmap(args, case_orphaned)
+  cases <- purrr::transpose(list(
+    name = orphans_names,
+    path = orphans_paths,
+    testcase = orphans_testcases,
+    verbose = rep_along(orphans_names, FALSE)
+  ))
+  orphaned_cases <- purrr::map(cases, orphaned_case)
   cases(orphaned_cases, pkg_path)
 }
 
 #' @rdname collect_cases
 #' @export
 collect_new_cases <- function(package = ".") {
-  filter_cases(collect_cases(package), "case_new")
+  filter_cases(collect_cases(package), "new_case")
 }
 
 #' @rdname collect_cases
 #' @export
 collect_mismatched_cases <- function(package = ".") {
-  filter_cases(collect_cases(package), "case_mismatched")
+  filter_cases(collect_cases(package), "mismatch_case")
 }
 
 #' @rdname collect_cases
 #' @export
 collect_orphaned_cases <- function(package = ".") {
-  filter_cases(collect_cases(package), "case_orphaned")
+  filter_cases(collect_cases(package), "orphaned_case")
 }
 
 #' Cases validation
@@ -90,7 +95,7 @@ collect_orphaned_cases <- function(package = ".") {
 #' @export
 validate_cases <- function(cases = collect_new_cases()) {
   stopifnot(is_cases(cases))
-  cases <- filter_cases(cases, c("case_new", "case_mismatch"))
+  cases <- filter_cases(cases, c("new_case", "mismatch_case"))
 
   pkg_path <- attr(cases, "pkg_path")
   if (is.null(pkg_path)) {
@@ -125,7 +130,7 @@ delete_orphaned_cases <- function(cases = collect_orphaned_cases()) {
     stop("Internal error: Package path is missing", call. = FALSE)
   }
 
-  cases <- filter_cases(cases, "case_orphaned")
+  cases <- filter_cases(cases, "orphaned_case")
   paths <- map_chr(cases, "testcase")
   walk(paths, file.remove)
 }
@@ -152,19 +157,19 @@ c.cases <- function(..., recursive = FALSE) {
 print.cases <- function(x, ...) {
   cat(sprintf("<cases>: %s\n", length(x)))
 
-  mismatched <- filter_cases(x, "case_mismatched")
+  mismatched <- filter_cases(x, "mismatch_case")
   if (length(mismatched) > 0) {
     cat("\nMismatched:\n")
     print_cases_names(mismatched)
   }
 
-  new <- filter_cases(x, "case_new")
+  new <- filter_cases(x, "new_case")
   if (length(new) > 0) {
     cat("\nNew:\n")
     print_cases_names(new)
   }
 
-  orphaned <- filter_cases(x, "case_orphaned")
+  orphaned <- filter_cases(x, "orphaned_case")
   if (length(orphaned) > 0) {
     figs_path <- file.path(attr(x, "pkg_path"), "tests")
 
@@ -192,24 +197,31 @@ filter_cases <- function(cases, type) {
   cases(filtered, attr(cases, "pkg_path"), attr(cases, "deps"))
 }
 
-make_case_constructor <- function(class) {
-  classes <- c(paste0("case_", class), "case")
-  function(name, path, testcase) {
-    case <- list(
-      name = name,
-      path = path,
-      testcase = testcase
-    )
-    structure(case, class = classes)
-  }
+case <- function(case) {
+  set_attrs(case, class = "case")
+}
+mismatch_case <- function(case) {
+  set_attrs(case, class = c("mismatch_case", "case"))
+}
+new_case <- function(case) {
+  set_attrs(case, class = c("new_case", "case"))
+}
+orphaned_case <- function(case) {
+  set_attrs(case, class = c("orphaned_case", "case"))
+}
+success_case <- function(case) {
+  set_attrs(case, class = c("success_case", "case"))
 }
 
-case_mismatch <- make_case_constructor("mismatch")
-case_new <- make_case_constructor("new")
-case_orphaned <- make_case_constructor("orphaned")
-case_success <- make_case_constructor("success")
-
-is_case <- function(case) inherits(case, "case")
-is_case_mismatch <- function(case) inherits(case, "case_mismatch")
-is_case_new <- function(case) inherits(case, "case_new")
-is_case_orphaned <- function(case) inherits(case, "case_orphaned")
+is_case <- function(case) {
+  inherits(case, "case")
+}
+is_mismatch_case <- function(case) {
+  inherits(case, "mismatch_case")
+}
+is_new_case <- function(case) {
+  inherits(case, "new_case")
+}
+is_orphaned_case <- function(case) {
+  inherits(case, "orphaned_case")
+}

R/shiny-server.R

@@ -3,7 +3,7 @@ vdiffrServer <- function(cases) {
   shiny::shinyServer(function(input, output) {
     cases <- shiny::reactiveValues(all = cases)
     cases$active <- shiny::reactive({
-      type <- input$type %||% "case_new"
+      type <- input$type %||% "new_case"
       filter_cases(cases$all, type)
     })
 
@@ -22,8 +22,8 @@ vdiffrServer <- function(cases) {
 }
 
 prettify_types <- function(x) {
-  ifelse(x == "case_mismatch", "Mismatched",
-  ifelse(x == "case_new", "New", "Orphaned"
+  ifelse(x == "mismatch_case", "Mismatched",
+  ifelse(x == "new_case", "New", "Orphaned"
   ))
 }
 
@@ -83,7 +83,7 @@ renderDiffer <- function(input, active_cases, widget) {
     before_path <- file.path(pkg_path, "tests", "testthat", case$path)
 
     after <- as_inline_svg(read_file(case$testcase))
-    if (is_case_new(case)) {
+    if (is_new_case(case)) {
       before <- after
     } else {
       before <- as_inline_svg(read_file(before_path))
@@ -94,8 +94,8 @@ renderDiffer <- function(input, active_cases, widget) {
 }
 
 withdraw_cases <- function(cases) {
-  validate_cases(filter_cases(cases, c("case_new", "case_mismatch")))
-  delete_orphaned_cases(filter_cases(cases, "case_orphaned"))
+  validate_cases(filter_cases(cases, c("new_case", "mismatch_case")))
+  delete_orphaned_cases(filter_cases(cases, "orphaned_case"))
 }
 
 validateSingleCase <- function(input, reactive_cases) {
@@ -123,7 +123,7 @@ validateGroupCases <- function(input, reactive_cases) {
 
         withdraw_cases(active_cases)
 
-        case_types <- c("case_new", "case_mismatch", "case_orphaned")
+        case_types <- c("new_case", "mismatch_case", "orphaned_case")
         types <- case_types[!case_types == type]
         cases <- filter_cases(cases, types)
 

R/testthat-reporter.R

@@ -37,17 +37,10 @@ active_collecter <- function() {
   vdiffr_env$active_collecter
 }
 
-maybe_collect_case <- function(type, ...) {
+maybe_collect_case <- function(case) {
   collecter <- active_collecter()
 
   if (!is.null(collecter)) {
-    case <- switch(type,
-      new = case_new(...),
-      mismatch = case_mismatch(...),
-      success = case_success(...),
-      stop("Unknown case type")
-    )
-
     collecter$add_case(case)
   }
 }

R/testthat-ui.R

@@ -61,10 +61,17 @@ expect_doppelganger <- function(title, fig, path = NULL, ...,
   path <- file.path("..", "figs", path)
   ensure_directories(dirname(path))
 
+  case <- case(list(
+    name = fig_name,
+    path = path,
+    testcase = testcase
+  ))
+
   if (file.exists(path)) {
-    exp <- compare_figs(testcase, path, fig_name = fig_name)
+    exp <- compare_figs(case)
   } else {
-    maybe_collect_case("new", name = fig_name, path = path, testcase = testcase)
+    case <- new_case(case)
+    maybe_collect_case(case)
     msg <- paste0("Figure not generated yet: ", fig_name, ".svg")
     exp <- expectation_new(msg)
   }
@@ -81,16 +88,18 @@ str_standardise <- function(s, sep = "-") {
   s
 }
 
-compare_figs <- function(testcase, path, fig_name) {
-  equal <- compare_files(testcase, normalizePath(path))
+compare_figs <- function(case) {
+  equal <- compare_files(case$testcase, normalizePath(case$path))
 
   if (equal) {
-    maybe_collect_case("success", name = fig_name, path = path, testcase = testcase)
     exp <- expectation_match("TRUE")
+    case <- success_case(case)
+    maybe_collect_case(case)
   } else {
-    maybe_collect_case("mismatch", name = fig_name, path = path, testcase = testcase)
-    msg <- paste0("Figures don't match: ", fig_name, ".svg\n")
+    msg <- paste0("Figures don't match: ", case$name, ".svg\n")
     exp <- expectation_mismatch(msg)
+    case <- mismatch_case(case)
+    maybe_collect_case(case)
   }
 
   exp

tests/testthat/test-orphaned.R

@@ -4,14 +4,14 @@ context("Orphaned")
 test_that("Orphaned figures are found", {
   skip_old_freetype()
 
-  orphaned <- filter_cases(mock_cases, "case_orphaned")
-  expect_equal(map_chr(orphaned, "name"), set_names(c("orphaned1", "orphaned2")))
+  orphaned <- filter_cases(mock_cases, "orphaned_case")
+  expect_equal(map_chr(unname(orphaned), "name"), c("orphaned1", "orphaned2"))
 })
 
 test_that("Orphaned files are found and deleted", {
   skip_old_freetype()
 
-  orphaned <- filter_cases(mock_cases, "case_orphaned")
+  orphaned <- filter_cases(mock_cases, "orphaned_case")
   files <- map_chr(orphaned, "path")
   files <- map_chr(files, purrr::partial(file.path, mock_pkg_dir, "tests", "testthat"))
   files_exist <- purrr::every(files, file.exists)