R/testthat.R

In testex: Add Tests to Examples

#' Support for `testthat` Expectations
#'
#' `testthat` support is managed through a "style" provided to [`testex`].
#' When using the `testthat` style (automatically when using the `@testthat`
#' tag), expectations are processed such that they always refer to the previous
#' example. Special care is taken to manage propagation of this value through
#' your test code, regardless of how `testthat` is executed.
#'
#' @examplesIf requireNamespace("testthat", quietly = TRUE)
#' # example code
#' 1 + 2
#'
#' # within `testex` block, test code refers to previous result with `.`
#' testex(style = "testthat", srcref = "abc.R:1:3", { \dontshow{
#'   . <- 3 # needed because roxygen2 @examplesIf mutates .Last.value
#'   }
#'   test_that("addition holds up", {
#'     expect_equal(., 3)
#'   })
#' })
#'
#' @name testex-testthat
NULL



#' Raise `testthat` Expectations With A Known Source Reference
#'
#' Retroactively assigns a source file and location to a expectation. This
#' allows `testthat` to report an origin for any code that raised an example
#' test failure from the source `roxygen2` code, even though the test code is
#' reconstructed from package documentation files.
#'
#' @param src A `srcref_key` which is parsed to produce an artificial [`srcref`]
#'   for the expectation signaled messages.
#' @param expr An expression to be evaluated. If an `expectation` condition is
#'   raised during its evaluation, its [`srcref`] is converted to `src`.
#' @param envir An environment in which to evaluate `expr`.
#'
#' @return The result of evaluating `expr`, or an expectation with appended
#'   [`srcref`] information if an expectation is raised.
#'
#' @export
with_srcref <- function(src, expr, envir = parent.frame()) {
  expr <- substitute(expr)
  withCallingHandlers(
    eval(expr, envir = envir),
    expectation = function(e) {
      srcref <- as.srcref(src)
      e[["srcref"]] <- srcref
      testthat::exp_signal(e)
      invokeRestart(computeRestarts()[[1L]])
    }
  )
}



#' Expect no Error
#'
#' @note This is a stop-gap implementation, and will only be used for legacy
#' versions of `testthat` before this was properly supported.
#'
#' A `testthat` expectation that the provided code can be evaluated without
#' producing an error. This is the most basic expectation one should expect of
#' any example code. Further expectations are provided in subsequent `testthat`
#' code.
#'
#' @param object An expression to evaluate
#' @param ... Additional arguments unused
#'
#' @return The value produced by the expectation code
#'
#' @export
fallback_expect_no_error <- function(object, ...) {
  object <- substitute(object)
  act <- list(
    val = tryCatch(eval(object, envir = parent.frame()), error = identity),
    lab = deparse(object)
  )

  testthat::expect(
    !inherits(act$val, "error"),
    failure_message = sprintf(
      "Example %s threw an error during execution.",
      act$lab
    ),
    ...
  )

  invisible(act$val)
}

#' Return appropriate call name provided testthat version
#' @noRd
expect_no_error_call <- function() {
  if (packageVersion("testthat") >= "3.1.5") {
    quote(testthat::expect_no_error)
  } else {
    quote(testex::fallback_expect_no_error)
  }
}



#' Execute examples from Rd files as `testthat` tests
#'
#' Reads examples from Rd files and constructs `testthat`-style tests.
#' `testthat` expectations are built such that
#'
#' 1. Each example expression is expected to run without error
#' 1. Any `testex` expectations are expected to pass
#'
#' Generally, you won't need to use this function directly. Instead, it
#' is called by a file generated by [`use_testex_as_testthat()`] which will add
#' any `testex` example tests to your existing `testthat` testing suite.
#'
#' @note
#' It is assumed that this function is used within a `testthat` run, when
#' the necessary packages are already installed and loaded.
#'
#' @param package A package name whose examples should be tested
#' @param path Optionally, a path to a source code directory to use. Will only
#'   have an effect if parameter `package` is missing.
#' @param test_dir An option directory where test files should be written.
#'   Defaults to a temporary directory.
#' @param clean Whether the `test_dir` should be removed upon completion of test
#'   execution. Defaults to `TRUE`.
#' @param overwrite Whether files should be overwritten if `test_dir` already
#'   exists. Defaults to `TRUE`.
#' @param roxygenize Whether R documentation files should be re-written using
#'   `roxygen2` prior to testing. When not `FALSE`, tests written in `roxygen2`
#'   tags will be used to update R documentation files prior to testing to use
#'   the most up-to-date example tests. May be `TRUE`, or a `list` of arguments
#'   passed to [`roxygen2::roxygenize`]. By default, only enabled when running
#'   outside of `R CMD check` and while taking `roxygen2` as a dependency.
#' @param ... Additional argument unused
#' @param reporter A `testthat` reporter to use. Defaults to the active
#'   reporter in the `testthat` environment or default reporter.
#'
#' @return The result of [`testthat::source_file()`], after iterating over
#'   generated test files.
#'
#' @examplesIf requireNamespace("testthat", quietly = TRUE)
#' \donttest{
#' # library(pkg.example)
#' path <- system.file("pkg.example", package = "testex")
#' test_examples_as_testthat(path = path)
#' }
#'
#' @export
test_examples_as_testthat <- function(
    package,
    path,
    ...,
    test_dir = file.path(tempdir(), "testex-tests"),
    clean = TRUE,
    overwrite = TRUE,
    roxygenize = !is_r_cmd_check() && uses_roxygen2(path),
    reporter = testthat::get_reporter()) {
  requireNamespace("testthat")
  testthat_envvar_val <- Sys.getenv("TESTTHAT")
  Sys.setenv(TESTTHAT = "true")
  on.exit(Sys.setenv(TESTTHAT = testthat_envvar_val), add = TRUE)

  if (missing(path)) {
    path <- find_package_root(testthat::test_path())
  }

  if (isTRUE(roxygenize)) roxygenize <- list()
  if (is.list(roxygenize) && requireNamespace("roxygen2", quietly = TRUE)) {
    args <- roxygenize
    args$package.dir <- path
    context <- cliless("{.pkg testex} re-roxygenizing examples")
    testthat::context_start_file(context)
    testthat::expect_invisible(suppressMessages({
      do.call(getExportedValue("roxygen2", "roxygenize"), args)
    }))
  }

  rds <- find_package_rds(package, path)
  test_dir_exists <- dir.exists(test_dir)

  if (!test_dir_exists) {
    dir.create(test_dir)
    if (clean) on.exit(unlink(test_dir), add = TRUE)
  }

  if (test_dir_exists && !overwrite) {
    test_files <- list.files(test_dir, full.names = TRUE)
    context <- cliless("{.pkg testex} testing examples")
    test_files(test_files, context, chdir = FALSE)
    return()
  }

  # find example sections and convert them to tests
  rd_examples <- Filter(Negate(is.null), lapply(rds, rd_extract_examples))
  test_files <- lapply(seq_along(rd_examples), function(i) {
    rd_filename <- names(rd_examples[i])
    rd_example <- rd_examples[[i]]

    # break up examples into examples and test, wrap examples in expectations
    exprs <- split_testonly_as_expr(rd_example)
    is_ex <- names(exprs) != "\\testonly"
    exprs[is_ex] <- lapply(
      exprs[is_ex],
      wrap_expect_no_error,
      value = quote(..Last.value) # can't use base::.Last.value in testthat env
    )

    # write out test code to file in test dir
    path <- file.path(test_dir, rd_filename)
    example_code <- vcapply(exprs, deparse_pretty)

    writeLines(paste(example_code, collapse = "\n\n"), path)
    path
  })

  context <- cliless("{.pkg testex} testing examples")
  test_files(test_files, context, chdir = FALSE)
}



#' Test a list of files
#'
#' @param files A collection of file paths to test
#' @param context An optional context message to display in `testthat` reporters
#' @param ... Additional arguments passed to `testhat::source_file`
#'
#' @return The result of [testthat::source_file()], after iterating over
#'   generated test files.
#'
#' @keywords internal
test_files <- function(files, context, ...) {
  testthat::context_start_file(context)
  for (file in files) testthat::source_file(file, ...)
}



#' Wraps an example expression in a `testthat` expectation to not error
#'
#' @param expr An expression to wrap in a `expect_no_error()` expectation. Uses
#'   `testthat`s version if recent enough version is available, or provides
#'   a fallback otherwise.
#' @param value A symbol to use to store the result of `expr`
#'
#' @return A [testthat::test_that()] call
#'
#' @importFrom utils packageVersion
#' @keywords internal
wrap_expect_no_error <- function(expr, value) {
  srckey <- srcref_key(expr, path = "root")
  # nocov start
  bquote(testthat::test_that("example executes without error", {
    testex::with_srcref(.(srckey), {
      .(value) <<- .(expect_no_error_call())(.(expr))
    })
  }))
  # nocov end
}



#' Determine which symbol to use by default when testing examples
#'
#' @return The value of the last test expression
#'
#' @keywords internal
get_example_value <- function() {
  if (testthat::is_testing()) {
    quote(..Last.value)
  } else {
    quote(.Last.value)
  }
}