Use a better helper for testing output types

R/output.R

@@ -60,8 +60,6 @@ handle_value <- function(handler, value, visible) {
   }
 }
 
-classes <- function(x) vapply(x, function(x) class(x)[1], character(1))
-
 render <- function(x) if (isS4(x)) methods::show(x) else print(x)
 
 #' Custom output handlers

tests/testthat/helper.R

@@ -6,3 +6,26 @@ evaluate_ <- function(text, ...) {
 
   evaluate(text, ...)
 }
+
+output_type <- function(x) {
+  if (is.character(x)) {
+    "text"
+  } else if (inherits(x, "error")) {
+    "error"
+  } else if (inherits(x, "warning")) {
+    "warning"
+  } else if (inherits(x, "message")) {
+    "message"
+  } else if (inherits(x, "recordedplot")) {
+    "plot"
+  } else if (inherits(x, "source")) {
+    "source"
+  } else {
+    class(x)[[1]]
+  }
+}
+output_types <- function(x) vapply(x, output_type, character(1))
+
+expect_output_types <- function(x, types) {
+  expect_equal(output_types(x), types)
+}

tests/testthat/test-errors.R

@@ -1,11 +1,11 @@
 test_that("all code run, even after error", {
   ev <- evaluate_('stop("1")\n2')
-  expect_length(ev, 4)
+  expect_output_types(ev, c("source", "error", "source", "text"))
 })
 
 test_that("code aborts on error if stop_on_error == 1L", {
   ev <- evaluate('stop("1")\n2', stop_on_error = 1L)
-  expect_length(ev, 2)
+  expect_output_types(ev, c("source", "error"))
 })
 
 test_that("code errors if stop_on_error == 2L", {

tests/testthat/test-eval.R

@@ -7,17 +7,9 @@ test_that("all condition handlers first capture output", {
     plot(3, main = "three")
     stop("this is an error")
   }
-  expect_equal(
-    classes(evaluate("test()")),
-    c(
-      "source",
-      "recordedplot",
-      "simpleMessage",
-      "recordedplot",
-      "simpleWarning",
-      "recordedplot",
-      "simpleError"
-    )
+  expect_output_types(
+    evaluate("test()"),
+    c("source", "plot", "message", "plot", "warning", "plot", "error")
   )
 })
 
@@ -28,15 +20,15 @@ test_that("all three states of keep_warning work as expected", {
 
   # warning captured in output
   expect_no_warning(ev <- evaluate("test()", keep_warning = TRUE))
-  expect_equal(classes(ev), c("source", "simpleWarning"))
+  expect_output_types(ev, c("source", "warning"))
 
   # warning propagated
   expect_warning(ev <- evaluate("test()", keep_warning = NA), "Hi")
-  expect_equal(classes(ev), "source")
+  expect_output_types(ev, "source")
 
   # warning ignored
   expect_no_warning(ev <- evaluate("test()", keep_warning = FALSE))
-  expect_equal(classes(ev), "source")
+  expect_output_types(ev, "source")
 })
 
 test_that("all three states of keep_message work as expected", {
@@ -46,15 +38,15 @@ test_that("all three states of keep_message work as expected", {
 
   # message captured in output
   expect_no_message(ev <- evaluate("test()", keep_message = TRUE))
-  expect_equal(classes(ev), c("source", "simpleMessage"))
+  expect_output_types(ev, c("source", "message"))
 
   # message propagated
   expect_message(ev <- evaluate("test()", keep_message = NA), "Hi")
-  expect_equal(classes(ev), "source")
+  expect_output_types(ev, "source")
 
   # message ignored
   expect_no_message(ev <- evaluate("test()", keep_message = FALSE))
-  expect_equal(classes(ev), "source")
+  expect_output_types(ev, "source")
 })
 
 test_that("can evaluate expressions of all lengths", {
@@ -77,7 +69,7 @@ test_that("log_echo causes output to be immediately written to stderr()", {
   expect_equal(out, "f()")
 
   # But still recorded in eval result
-  expect_length(res, 2)
+  expect_output_types(res, c("source", "text"))
   expect_equal(res[[1]]$src, "f()")
 })
 
@@ -92,7 +84,6 @@ test_that("log_warning causes warnings to be immediately written to stderr()", {
   expect_equal(out, c("Warning in f():", "Hi!"))
 
   # But still recorded in eval result
-  expect_length(res, 2)
   expect_equal(res[[1]]$src, "f()")
   expect_equal(res[[2]], simpleWarning("Hi!", quote(f())))
 })
@@ -109,7 +100,7 @@ test_that("can conditionally omit output with output handler", {
   hide <- function(x) invisible(x)
 
   out <- evaluate("hide(x <- 1)\nx", output_handler = handler)
-  expect_length(out, 2)
+  expect_output_types(out, c("source", "text"))
   expect_snapshot(replay(out))
 })
 

tests/testthat/test-evaluate.R

@@ -3,9 +3,7 @@ test_that("file with only comments runs", {
     # This test case contains no executable code
     # but it shouldn't throw an error
   ")
-  expect_length(ev, 2)
-
-  expect_equal(classes(ev), c("source", "source"))
+  expect_output_types(ev, c("source", "source"))
 })
 
 test_that("data sets loaded", {
@@ -15,7 +13,7 @@ test_that("data sets loaded", {
     data(barley, package = "lattice")
     barley
   ')
-  expect_length(ev, 3)
+  expect_output_types(ev, c("source", "source", "text"))
 })
 
 # # Don't know how to implement this
@@ -26,7 +24,7 @@ test_that("data sets loaded", {
 
 test_that("terminal newline not needed", {
   ev <- evaluate("cat('foo')")
-  expect_length(ev, 2)
+  expect_output_types(ev, c("source", "text"))
   expect_equal(ev[[2]], "foo")
 })
 
@@ -45,29 +43,29 @@ test_that("errors during printing visible values are captured", {
   a <- new('A', function() b)
 
   ev <- evaluate("a")
-  expect_s3_class(ev[[2]], "error")
+  expect_output_types(ev, c("source", "error"))
 })
 
 test_that("respects warn options", {
   # suppress warnings
   withr::local_options(warn = -1)
   ev <- evaluate("warning('hi')")
-  expect_equal(classes(ev), "source")
+  expect_output_types(ev, "source")
 
   # delayed warnings are always immediate in knitr
   withr::local_options(warn = 0)
   ev <- evaluate("warning('hi')")
-  expect_equal(classes(ev), c("source", "simpleWarning"))
+  expect_output_types(ev, c("source", "warning"))
 
   # immediate warnings
   withr::local_options(warn = 1)
   ev <- evaluate("warning('hi')")
-  expect_equal(classes(ev), c("source", "simpleWarning"))
+  expect_output_types(ev, c("source", "warning"))
 
   # warnings become errors
   withr::local_options(warn = 2)
   ev <- evaluate("warning('hi')")
-  expect_equal(classes(ev), c("source", "simpleError"))
+  expect_output_types(ev, c("source", "error"))
 })
 
 test_that("output and plots interleaved correctly", {
@@ -77,21 +75,15 @@ test_that("output and plots interleaved correctly", {
       plot(i)
     }
   ")
-  expect_equal(
-    classes(ev),
-    c("source", "character", "recordedplot", "character", "recordedplot")
-  )
+  expect_output_types(ev, c("source", "text", "plot", "text", "plot"))
 
   ev <- evaluate_("
     for (i in 1:2) {
       plot(i)
       cat(i)
     }
   ")
-  expect_equal(
-    classes(ev),
-    c("source", "recordedplot", "character", "recordedplot", "character")
-  )
+  expect_output_types(ev, c("source", "plot", "text", "plot", "text"))
 })
 
 test_that("return value of value handler inserted directly in output list", {
@@ -104,10 +96,7 @@ test_that("return value of value handler inserted directly in output list", {
     ggplot(mtcars, aes(mpg, wt)) + geom_point()
   ', output_handler = new_output_handler(value = identity)
   )
-  expect_equal(
-    classes(ev),
-    c("source", "numeric", "source", "source", "source", "gg")
-  )
+  expect_output_types(ev, c("source", "numeric", "source", "source", "source", "gg"))
 })
 
 test_that("invisible values can also be saved if value handler has two arguments", {
@@ -117,17 +106,18 @@ test_that("invisible values can also be saved if value handler has two arguments
   expect_true(show_value(handler, FALSE))
 
   ev <- evaluate("x<-1:10", output_handler = handler)
-  expect_equal(classes(ev), c("source", "integer"))
+  expect_output_types(ev, c("source", "integer"))
 })
 
 test_that("multiple expressions on one line can get printed as expected", {
   ev <- evaluate("x <- 1; y <- 2; x; y")
-  expect_equal(classes(ev), c("source", "character", "character"))
+  expect_output_types(ev, c("source", "text", "text"))
 })
 
 test_that("multiple lines of comments do not lose the terminating \\n", {
   ev <- evaluate("# foo\n#bar")
-  expect_equal(ev[[1]][["src"]], "# foo\n")
+  expect_output_types(ev, c("source", "source"))
+  expect_equal(ev[[1]]$src, "# foo\n")
 })
 
 test_that("user can register calling handlers", {