Implement verify_output() (#906)

Fixes #782. Fixes #834.

DESCRIPTION

@@ -19,6 +19,7 @@ Imports:
     cli,
     crayon (>= 1.3.4),
     digest,
+    evaluate,
     magrittr,
     methods,
     praise,
@@ -104,4 +105,5 @@ Collate:
     'try-again.R'
     'utils-io.R'
     'utils.R'
+    'verify-output.R'
     'watcher.R'

NAMESPACE

@@ -15,6 +15,12 @@ S3method(format,expectation_error)
 S3method(format,expectation_success)
 S3method(format,mismatch_character)
 S3method(format,mismatch_numeric)
+S3method(output_replay,character)
+S3method(output_replay,error)
+S3method(output_replay,message)
+S3method(output_replay,recordedplot)
+S3method(output_replay,source)
+S3method(output_replay,warning)
 S3method(print,comparison)
 S3method(print,expectation)
 S3method(print,mismatch_character)
@@ -161,6 +167,7 @@ export(testthat_examples)
 export(throws_error)
 export(try_again)
 export(use_catch)
+export(verify_output)
 export(watch)
 export(with_mock)
 export(with_reporter)

R/expect-known.R

@@ -52,34 +52,38 @@ expect_known_output <- function(object, file,
   act$lab <- label %||% quo_label(act$quo)
   act <- append(act, eval_with_output(object, print = print, width = width))
 
-  if (!file.exists(file)) {
+  compare_file(file, act$out, update = update, info = info, ...)
+  invisible(act$val)
+}
+
+compare_file <- function(path, lines, ..., update = TRUE, info = NULL) {
+  if (!file.exists(path)) {
     warning("Creating reference output", call. = FALSE)
-    write_lines(act$out, file)
+    write_lines(lines, path)
     succeed()
-  } else {
-    ref_out <- read_lines(file)
-    if (update) {
-      write_lines(act$out, file)
-      if (!all_utf8(act$out)) {
-        warning("New reference output is not UTF-8 encoded", call. = FALSE)
-      }
-    }
-    if (!all_utf8(ref_out)) {
-      warning("Reference output is not UTF-8 encoded", call. = FALSE)
-    }
+    return()
+  }
 
-    comp <- compare(act$out, enc2native(ref_out), ...)
-    expect(
-      comp$equal,
-      sprintf(
-        "%s has changed from known value recorded in %s.\n%s",
-        act$lab, encodeString(file, quote = "'"), comp$message
-      ),
-      info = info
-    )
+  old_lines <- read_lines(path)
+  if (update) {
+    write_lines(lines, path)
+    if (!all_utf8(lines)) {
+      warning("New reference output is not UTF-8 encoded", call. = FALSE)
+    }
+  }
+  if (!all_utf8(old_lines)) {
+    warning("Reference output is not UTF-8 encoded", call. = FALSE)
   }
 
-  invisible(act$val)
+  comp <- compare(lines, enc2native(old_lines), ...)
+  expect(
+    comp$equal,
+    sprintf(
+      "Results have changed from known value recorded in %s.\n%s",
+      encodeString(path, quote = "'"), comp$message
+    ),
+    info = info
+  )
 }
 
 #' @export

R/verify-output.R

@@ -0,0 +1,108 @@
+#' Verify output
+#'
+#' This is a regression test records interwoven code and output into a file,
+#' similar to Rmd. It's designed particularly for testing print methods and
+#' error messages, where the primary goal is to ensure that the output is
+#' helpful to a human. Obviously, there's no way to test that automatically,
+#' so the best we can do is make the results explicit by saving to a text file.
+#' This makes the presentation easier to see in code reviews, and avoids
+#' changing it accidentally.
+#'
+#' @section CRAN:
+#' On CRAN, `verify_output()` will not fail if the output changes. This is
+#' beause tests of print methods and error messages are often fragile due to
+#' implicit dependencies on other packages, and failure does not imply
+#' incorrect computation, just a change in presentation.
+#'
+#' @section Differences to Rmd:
+#' `verify_output()` can only capture the abstract syntax tree, losing all
+#' whitespace and comments. To mildy offset this limitation, bare string
+#' are turned into comments.
+#'
+#' @param path Path to save file. Typically this will be a call to
+#'   [test_path()] so that the same path when the code is run interactively.
+#' @param code Code to execute.
+#' @param width Width of console output
+#' @param crayon Enable crayon package colouring?
+#' @export
+verify_output <- function(path, code, width = 80, crayon = FALSE) {
+  code <- enquo(code)
+
+  env <- get_env(code)
+  expr <- get_expr(code)
+
+  if (is_call(expr, "{")) {
+    exprs <- as.list(expr[-1])
+  } else {
+    exprs <- list(expr)
+  }
+
+  withr::local_options(list(width = width, crayon.enabled = crayon))
+  withr::local_envvar(list(RSTUDIO_CONSOLE_WIDTH = width))
+
+  exprs <- lapply(exprs, function(x) if (is.character(x)) paste0("# ", x) else expr_deparse(x))
+  source <- unlist(exprs, recursive = FALSE)
+
+  results <- evaluate::evaluate(source, envir = env)
+  output <- unlist(lapply(results, output_replay))
+
+  if (!interactive()) {
+    skip_on_cran()
+  }
+  compare_file(path, output, update = TRUE)
+  invisible()
+}
+
+
+output_replay <- function(x) {
+  UseMethod("output_replay", x)
+}
+
+#' @export
+output_replay.character <- function(x) {
+  sub("\n$", "", x)
+}
+
+#' @export
+output_replay.source <- function(x) {
+  lines <- strsplit(x$src, "\n")[[1]]
+  n <- length(lines)
+
+  lines[1] <- paste0("> ", lines[1])
+  if (n > 1) {
+    lines[2:n] <- paste0("+ ", lines[2:n])
+  }
+
+  lines
+}
+
+#' @export
+output_replay.error <- function(x) {
+  if (is.null(x$call)) {
+    paste0("Error: ", x$message)
+  } else {
+    call <- deparse(x$call)
+    paste0("Error in ", call, ": ", x$message)
+  }
+}
+
+#' @export
+output_replay.warning <- function(x) {
+  if (is.null(x$call)) {
+    paste0("Warning: ", x$message)
+  } else {
+    call <- deparse(x$call)
+    paste0("Warning in ", call, ": ", x$message)
+  }
+}
+
+#' @export
+output_replay.message <- function(x) {
+  # Messages are the only conditions where a new line is appended automatically
+  paste0("Message: ", sub("\n$", "", x$message))
+}
+
+#' @export
+output_replay.recordedplot <- function(x) {
+  abort("Plots are not supported")
+}

tests/testthat/test-verify-conditions.txt

@@ -0,0 +1,12 @@
+> message("Message")
+Message: Message
+> # With calls
+> warning("Warning")
+Warning in eval(expr, envir, enclos): Warning
+> stop("Error")
+Error in eval(expr, envir, enclos): Error
+> # Without calls
+> warning("Warning", call. = FALSE)
+Warning: Warning
+> stop("Error", call. = FALSE)
+Error: Error

tests/testthat/test-verify-output.R

@@ -0,0 +1,28 @@
+test_that("can record all types of output", {
+  verify_output(test_path("test-verify-output.txt"), {
+    "Output"
+    1 + 2
+    invisible(1:10)
+    12345678 + 12345678 + 12345678 + 12345678 + 12345678 + 12345678 +
+      12345678 + 12345678 + 12345678 + 12345678 + 12345678
+  })
+})
+
+test_that("can record all types of output", {
+  verify_output(test_path("test-verify-conditions.txt"), {
+    message("Message")
+
+    "With calls"
+    warning("Warning")
+    stop("Error")
+
+    "Without calls"
+    warning("Warning", call. = FALSE)
+    stop("Error", call. = FALSE)
+  })
+})
+
+test_that("can't record plots", {
+  skip_if(interactive())
+  expect_error(verify_output("path", plot(1:10)), "Plots")
+})

tests/testthat/test-verify-output.txt

@@ -0,0 +1,7 @@
+> # Output
+> 1 + 2
+[1] 3
+> invisible(1:10)
+> 12345678 + 12345678 + 12345678 + 12345678 + 12345678 + 12345678 + 12345678 +
++ 12345678 + 12345678 + 12345678 + 12345678
+[1] 135802458