File: reporter-zzz.R

package info (click to toggle)
r-cran-testthat 3.2.3-1
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 3,452 kB
  • sloc: cpp: 9,261; ansic: 37; sh: 14; makefile: 5
file content (107 lines) | stat: -rw-r--r-- 2,777 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
#' Get and set active reporter.
#'
#' `get_reporter()` and `set_reporter()` access and modify the current "active"
#' reporter. Generally, these functions should not be called directly; instead
#' use `with_reporter()` to temporarily change, then reset, the active reporter.
#'
#'
#' @param reporter Reporter to use to summarise output. Can be supplied
#'   as a string (e.g. "summary") or as an R6 object
#'   (e.g. `SummaryReporter$new()`).
#'
#'   See [Reporter] for more details and a list of built-in reporters.
#' @param code Code to execute.
#' @return `with_reporter()` invisible returns the reporter active when `code`
#'   was evaluated.
#' @param start_end_reporter Should the reporters `start_reporter()` and
#'   `end_reporter()` methods be called? For expert use only.
#' @keywords internal
#' @name reporter-accessors
NULL

#' @rdname reporter-accessors
#' @export
set_reporter <- function(reporter) {
  old <- the$reporter
  the$reporter <- reporter
  invisible(old)
}

#' @rdname reporter-accessors
#' @export
get_reporter <- function() {
  the$reporter
}

#' @rdname reporter-accessors
#' @export
with_reporter <- function(reporter, code, start_end_reporter = TRUE) {
  reporter <- find_reporter(reporter)

  old <- set_reporter(reporter)
  on.exit(set_reporter(old), add = TRUE)

  if (start_end_reporter) {
    reporter$start_reporter()
  }

  tryCatch(code, testthat_abort_reporter = function(cnd) {
    cat(conditionMessage(cnd), "\n")
    NULL
  })

  if (start_end_reporter) {
    reporter$end_reporter()
  }

  invisible(reporter)
}

stop_reporter <- function(message) {
  cli::cli_abort(
    message,
    class = "testthat_abort_reporter",
    call = NULL
  )
}

#' Find reporter object given name or object.
#'
#' If not found, will return informative error message.
#' Pass a character vector to create a [MultiReporter] composed
#' of individual reporters.
#' Will return null if given NULL.
#'
#' @param reporter name of reporter(s), or reporter object(s)
#' @keywords internal
find_reporter <- function(reporter) {
  if (is.null(reporter)) return(NULL)

  if (inherits(reporter, "R6ClassGenerator")) {
    reporter$new()
  } else if (inherits(reporter, "Reporter")) {
    reporter
  } else if (is.character(reporter)) {
    if (length(reporter) <= 1L) {
      find_reporter_one(reporter)
    } else {
      MultiReporter$new(reporters = lapply(reporter, find_reporter_one))
    }
  } else {
    stop("Invalid input", call. = FALSE)
  }
}

find_reporter_one <- function(reporter, ...) {
  stopifnot(is.character(reporter))

  name <- reporter
  substr(name, 1, 1) <- toupper(substr(name, 1, 1))
  name <- paste0(name, "Reporter")

  if (!exists(name)) {
    stop("Can not find test reporter ", reporter, call. = FALSE)
  }

  get(name)$new(...)
}