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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
#' Verify output
#'
#' @description
#' `r lifecycle::badge("superseded")`
#'
#' This function is superseded in favour of `expect_snapshot()` and friends.
#'
#' This is a regression test that records interwoven code and output into a
#' file, in a similar way to knitting an `.Rmd` file (but see caveats below).
#'
#' `verify_output()` is designed particularly for testing print methods and error
#' messages, where the primary goal is to ensure that the output is helpful to
#' a human. Obviously, you can't test that with code, so the best you can do is
#' make the results explicit by saving them to a text file. This makes the output
#' easy to verify in code reviews, and ensures that you don't change the output
#' by accident.
#'
#' `verify_output()` is designed to be used with git: to see what has changed
#' from the previous run, you'll need to use `git diff` or similar.
#'
#' @section Syntax:
#' `verify_output()` can only capture the abstract syntax tree, losing all
#' whitespace and comments. To mildly offset this limitation:
#'
#' - Strings are converted to R comments in the output.
#' - Strings starting with `# ` are converted to headers in the output.
#'
#' @section CRAN:
#' On CRAN, `verify_output()` will never fail, even if the output changes.
#' This avoids false positives because tests of print methods and error
#' messages are often fragile due to implicit dependencies on other packages,
#' and failure does not imply incorrect computation, just a change in
#' presentation.
#'
#' @param path Path to record results.
#'
#' This should usually be a call to [test_path()] in order to ensure that
#' the same path is used when run interactively (when the working directory
#' is typically the project root), and when run as an automated test (when
#' the working directory will be `tests/testthat`).
#' @param code Code to execute. This will usually be a multiline expression
#' contained within `{}` (similarly to `test_that()` calls).
#' @param width Width of console output
#' @param crayon Enable cli/crayon package colouring?
#' @param unicode Enable cli package UTF-8 symbols? If you set this to
#' `TRUE`, call `skip_if(!cli::is_utf8_output())` to disable the
#' test on your CI platforms that don't support UTF-8 (e.g. Windows).
#' @param env The environment to evaluate `code` in.
#' @export
#' @keywords internal
verify_output <- function(path, code, width = 80, crayon = FALSE,
unicode = FALSE, env = caller_env()) {
local_reproducible_output(width = width, crayon = crayon, unicode = unicode)
expr <- substitute(code)
output <- verify_exec(expr, env = env)
if (!interactive() && on_cran()) {
skip("On CRAN")
}
compare_file(path, output, update = TRUE)
invisible()
}
verify_exec <- function(expr, env = caller_env(), replay = output_replay) {
if (is_call(expr, "{")) {
exprs <- as.list(expr[-1])
} else {
exprs <- list(expr)
}
device_path <- withr::local_tempfile(pattern = "verify_exec_")
withr::local_pdf(device_path)
grDevices::dev.control(displaylist = "enable")
exprs <- lapply(exprs, function(x) if (is.character(x)) paste0("# ", x) else expr_deparse(x))
source <- unlist(exprs, recursive = FALSE)
handler <- evaluate::new_output_handler(value = testthat_print)
results <- evaluate::evaluate(source, envir = env,
new_device = FALSE,
output_handler = handler
)
output <- unlist(lapply(results, replay))
output <- gsub("\r", "", output, fixed = TRUE)
output
}
output_replay <- function(x) {
UseMethod("output_replay", x)
}
#' @export
output_replay.character <- function(x) {
c(split_lines(x), "")
}
#' @export
output_replay.source <- function(x) {
lines <- split_lines(x$src)
# Remove header of lines so they don't get prefixed
first <- lines[[1]]
if (grepl("^# # ", first)) {
header <- gsub("^# # ", "", first)
lines <- lines[-1]
} else {
header <- NULL
}
n <- length(lines)
if (n > 0) {
lines[1] <- paste0("> ", lines[1])
if (n > 1) {
lines[2:n] <- paste0("+ ", lines[2:n])
}
}
if (!is.null(header)) {
underline <- strrep("=", nchar(header))
lines <- c("", header, underline, "", lines)
}
lines
}
#' @export
output_replay.error <- function(x) {
msg <- cnd_message(x)
if (is.null(x$call)) {
msg <- paste0("Error: ", msg)
} else {
call <- deparse(x$call)
msg <- paste0("Error in ", call, ": ", msg)
}
c(split_lines(msg), "")
}
#' @export
output_replay.warning <- function(x) {
msg <- cnd_message(x)
if (is.null(x$call)) {
msg <- paste0("Warning: ", msg)
} else {
call <- deparse(x$call)
msg <- paste0("Warning in ", call, ": ", msg)
}
c(split_lines(msg), "")
}
#' @export
output_replay.message <- function(x) {
# Messages are the only conditions where a new line is appended automatically
msg <- paste0("Message: ", sub("\n$", "", cnd_message(x)))
c(split_lines(msg), "")
}
#' @export
output_replay.recordedplot <- function(x) {
abort("Plots are not supported")
}
# Helpers ------------------------------------------------------------
split_lines <- function(x) {
strsplit(x, "\n")[[1]]
}
|
