tests/testthat/test-output-handler.R

In r-lib/evaluate: Parsing and Evaluation Tools that Provide More Details than the Default

test_that("calling handlers are checked", {
  expect_snapshot(error = TRUE, {
    check_handlers(list(condition = 1))
    check_handlers(list(function(...) NULL))
    check_handlers(stats::setNames(list(function(...) NULL), NA))
    check_handlers(stats::setNames(list(function(...) NULL), ""))
  })
})

test_that("text output handler is called with text", {
  text <- NULL
  oh <- new_output_handler(text = function(o) text <<- o)

  evaluate("print('abc')", output_handler = oh)
  expect_equal(text, "[1] \"abc\"\n")
})

test_that("graphic output handler not called with no graphics", {
  graphics <- NULL
  oh <- new_output_handler(graphics = function(o) graphics <<- 1)

  evaluate("print('abc')", output_handler = oh)
  expect_equal(graphics, NULL)
})


test_that("can conditionally omit output with output handler", {
  hide_source <- function(src, tle) {
    if (length(tle) == 0) {
      src
    } else if (is.call(tle[[1]]) && identical(tle[[1]][[1]], quote(hide))) {
      NULL
    } else {
      src
    }
  }
  handler <- new_output_handler(source = hide_source)
  hide <- function(x) invisible(x)

  out <- evaluate("hide(x <- 1)\nx", output_handler = handler)
  expect_output_types(out, c("source", "text"))
  expect_snapshot(replay(out))
})

test_that("source handled called correctly when src is unparseable", {
  src <- NULL
  call <- NULL
  capture_args <- function(src, call) {
    src <<- src
    call <<- call

    src
  }
  handler <- new_output_handler(source = capture_args)

  evaluate("x + ", output_handler = handler)
  expect_equal(src, new_source("x + "))
  expect_equal(call, expression())
})


test_that("return value of value handler inserted directly in output list", {
  skip_if_not_installed("ggplot2")

  ev <- evaluate(
    function() {
      rnorm(10)
      x <- list("I\'m a list!")
      ggplot2::ggplot(mtcars, ggplot2::aes(mpg, wt))
    },
    output_handler = new_output_handler(value = identity)
  )
  expect_output_types(ev, c("source", "numeric", "source", "source", "gg"))
})

test_that("invisible values can also be saved if value handler has two arguments", {
  handler <- new_output_handler(value = function(x, visible) {
    x # always returns a visible value
  })
  expect_true(show_value(handler, FALSE))

  ev <- evaluate("x<-1:10", output_handler = handler)
  expect_output_types(ev, c("source", "integer"))
})

test_that("user can register calling handlers", {
  cnd <- structure(list(), class = c("foobar", "condition"))
  hnd <- function(cnd) handled <<- cnd

  handled <- NULL
  hnd <- function(cnd) handled <<- cnd

  out_hnd <- new_output_handler(calling_handlers = list(foobar = hnd))
  evaluate("signalCondition(cnd)", output_handler = out_hnd)
  expect_s3_class(handled, "foobar")

  handled <- NULL
  out_hnd <- new_output_handler(calling_handlers = list(error = hnd))
  evaluate("stop('tilt')", stop_on_error = 0, output_handler = out_hnd)
  expect_s3_class(handled, "error")
})