R/local.R

Defines functions local_interactive_reporter local_test_directory local_width waldo_compare local_reporter_output local_reproducible_output local_test_context

Documented in local_reproducible_output local_test_context local_test_directory

#' Locally set options for maximal test reproducibility
#'
#' @description
#' `local_test_context()` is run automatically by `test_that()` but you may
#' want to run it yourself if you want to replicate test results interactively.
#' If run inside a function, the effects are automatically reversed when the
#' function exits; if running in the global environment, use
#' [withr::deferred_run()] to undo.
#'
#' `local_reproducible_output()` is run automatically by `test_that()` in the
#' 3rd edition. You might want to call it to override the the default settings
#' inside a test, if you want to test Unicode, coloured output, or a
#' non-standard width.
#'
#' @details
#' `local_test_context()` sets `TESTTHAT = "true"`, which ensures that
#' [is_testing()] returns `TRUE` and allows code to tell if it is run by
#' testthat.
#'
#' In the third edition, `local_test_context()` also calls
#' `local_reproducible_output()` which temporary sets the following options:
#'
#' * `cli.dynamic = FALSE` so that tests assume that they are not run in
#'   a dynamic console (i.e. one where you can move the cursor around).
#' * `cli.unicode` (default: `FALSE`) so that the cli package never generates
#'   unicode output (normally cli uses unicode on Linux/Mac but not Windows).
#'   Windows can't easily save unicode output to disk, so it must be set to
#'   false for consistency.
#' * `cli.condition_width = Inf` so that new lines introduced while
#'   width-wrapping condition messages don't interfere with message matching.
#' * `crayon.enabled` (default: `FALSE`) suppresses ANSI colours generated by
#'   the cli and crayon packages (normally colours are used if cli detects
#'   that you're in a terminal that supports colour).
#' * `cli.num_colors` (default: `1L`) Same as the crayon option.
#' * `lifecycle_verbosity = "warning"` so that every lifecycle problem always
#'   generates a warning (otherwise deprecated functions don't generate a
#'   warning every time).
#' * `max.print = 99999` so the same number of values are printed.
#' * `OutDec = "."` so numbers always uses `.` as the decimal point
#'   (European users sometimes set `OutDec = ","`).
#' * `rlang_interactive = FALSE` so that [rlang::is_interactive()] returns
#'   `FALSE`, and code that uses it pretends you're in a non-interactive
#'   environment.
#' * `useFancyQuotes = FALSE` so base R functions always use regular (straight)
#'   quotes (otherwise the default is locale dependent, see [sQuote()] for
#'   details).
#' * `width` (default: 80) to control the width of printed output (usually this
#'   varies with the size of your console).
#'
#' And modifies the following env vars:
#'
#' * Unsets `RSTUDIO`, which ensures that RStudio is never detected as running.
#' * Sets `LANGUAGE = "en"`, which ensures that no message translation occurs.
#'
#' Finally, it sets the collation locale to "C", which ensures that character
#' sorting the same regardless of system locale.
#'
#' @export
#' @param .env Environment to use for scoping; expert use only.
#' @examples
#' local({
#'   local_test_context()
#'   cat(cli::col_blue("Text will not be colored"))
#'   cat(cli::symbol$ellipsis)
#'   cat("\n")
#' })
local_test_context <- function(.env = parent.frame()) {
  withr::local_envvar("_R_CHECK_BROWSER_NONINTERACTIVE_" = "true", TESTTHAT = "true", .local_envir = .env)
  if (edition_get() >= 3) {
    local_reproducible_output(.env = .env)
  }
}

#' @export
#' @param width Value of the `"width"` option.
#' @param crayon Determines whether or not crayon (now cli) colour
#'   should be applied.
#' @param unicode Value of the `"cli.unicode"` option.
#'   The test is skipped if `` l10n_info()$`UTF-8` `` is `FALSE`.
#' @param rstudio Should we pretend that we're inside of RStudio?
#' @param hyperlinks Should we use ANSI hyperlinks.
#' @param lang Optionally, supply a BCP47 language code to set the language
#'   used for translating error messages. This is a lower case two letter
#'   [ISO 639 country code](https://en.wikipedia.org/wiki/List_of_ISO_639-1_codes),
#'   optionally followed by "_" or "-" and an upper case two letter
#'   [ISO 3166 region code](https://en.wikipedia.org/wiki/ISO_3166-2).
#' @rdname local_test_context
#' @examples
#' test_that("test ellipsis", {
#'   local_reproducible_output(unicode = FALSE)
#'   expect_equal(cli::symbol$ellipsis, "...")
#'
#'   local_reproducible_output(unicode = TRUE)
#'   expect_equal(cli::symbol$ellipsis, "\u2026")
#' })
local_reproducible_output <- function(width = 80,
                                      crayon = FALSE,
                                      unicode = FALSE,
                                      rstudio = FALSE,
                                      hyperlinks = FALSE,
                                      lang = "en",
                                      .env = parent.frame()) {

  if (unicode) {
    # If you force unicode display, you _must_ skip the test on non-utf8
    # locales; otherwise it's guaranteed to fail
    skip_if(!l10n_info()$`UTF-8`, "non utf8 locale")
  }

  local_width(width = width, .env = .env)
  withr::local_options(
    crayon.enabled = crayon,
    cli.hyperlink = hyperlinks,
    cli.hyperlink_run = hyperlinks,
    cli.hyperlink_help = hyperlinks,
    cli.hyperlink_vignette = hyperlinks,
    cli.dynamic = FALSE,
    cli.unicode = unicode,
    cli.condition_width = Inf,
    cli.num_colors = if (crayon) 8L else 1L,
    useFancyQuotes = FALSE,
    lifecycle_verbosity = "warning",
    OutDec = ".",
    rlang_interactive = FALSE,
    max.print = 99999,
    .local_envir = .env,
  )
  withr::local_envvar(
    RSTUDIO = if (rstudio) 1 else NA,
    RSTUDIO_SESSION_PID = if (rstudio) Sys.getpid() else NA,
    RSTUDIO_CHILD_PROCESS_PANE = if (rstudio) "build" else NA,
    RSTUDIO_CLI_HYPERLINKS = if (rstudio) 1 else NA,
    .local_envir = .env
  )

  if (isTRUE(capabilities("NLS")) && Sys.getenv("LANG") != "C") {
    withr::local_language(lang, .local_envir = .env)
  }

  withr::local_collate("C", .local_envir = .env)
}

local_reporter_output <- function(.env = parent.frame()) {
  reporter <- get_reporter()
  if (!is.null(reporter)) {
    reporter$local_user_output(.env)
  }
}

waldo_compare <- function(x, y, ..., x_arg = "x", y_arg = "y") {
  # Need to very carefully isolate this change to this function - can not set
  # in expectation functions because part of expectation handling bubbles
  # up through calling handlers, which are run before on.exit()
  local_reporter_output()

  waldo::compare(x, y,..., x_arg = x_arg, y_arg = y_arg)
}

local_width <- function(width = 80, .env = parent.frame()) {
  withr::local_options(width = width, cli.width = width, .local_envir = .env)
  withr::local_envvar(RSTUDIO_CONSOLE_WIDTH = width, .local_envir = .env)
}


#' Locally set test directory options
#'
#' For expert use only.
#'
#' @param path Path to directory of files
#' @param package Optional package name, if known.
#' @export
#' @keywords internal
local_test_directory <- function(path, package = NULL, .env = parent.frame()) {
  # Set edition before changing working directory in case path is relative
  local_edition(find_edition(path, package), .env = .env)

  withr::local_dir(
    path,
    .local_envir = .env
  )
  withr::local_envvar(
    R_TESTS = "",
    TESTTHAT = "true",
    TESTTHAT_PKG = package,
    .local_envir = .env
  )
}

local_interactive_reporter <- function(.env = parent.frame()) {
  # Definitely not on CRAN
  withr::local_envvar(NOT_CRAN = "true", .local_envir = .env)
  withr::local_options(testthat_interactive = TRUE, .local_envir = .env)

  # Use edition from working directory
  local_edition(find_edition("."), .env = .env)

  # Use StopReporter
  reporter <- StopReporter$new()
  old <- set_reporter(reporter)
  withr::defer(reporter$stop_if_needed(), envir = .env)
  withr::defer(set_reporter(old), envir = .env)

  reporter
}

Try the testthat package in your browser

Any scripts or data that you put into this service are public.

testthat documentation built on Oct. 6, 2023, 5:10 p.m.