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
|
capture_failure <- new_capture("expectation_failure")
capture_success <- function(expr) {
cnd <- NULL
withCallingHandlers(
expr,
expectation_failure = function(cnd) {
invokeRestart("continue_test")
},
expectation_success = function(cnd) {
cnd <<- cnd
}
)
cnd
}
new_capture("expectation_success")
#' Tools for testing expectations
#'
#' @description
#' * `expect_sucess()` and `expect_failure()` check that there's at least
#' one success or failure respectively.
#' * `expect_snapshot_failure()` records the failure message so that you can
#' manually check that it is informative.
#' * `expect_no_success()` and `expect_no_failure()` check that are no
#' successes or failures.
#'
#' Use `show_failure()` in examples to print the failure message without
#' throwing an error.
#'
#' @param expr Code to evalute
#' @param message Check that the failure message matches this regexp.
#' @param ... Other arguments passed on to [expect_match()].
#' @export
expect_success <- function(expr) {
exp <- capture_success(expr)
if (is.null(exp)) {
fail("Expectation did not succeed")
} else {
succeed()
}
invisible(NULL)
}
#' @export
#' @rdname expect_success
expect_no_success <- function(expr) {
exp <- capture_success(expr)
if (!is.null(exp)) {
fail("Expectation succeeded")
} else {
succeed()
}
invisible(NULL)
}
#' @export
#' @rdname expect_success
expect_failure <- function(expr, message = NULL, ...) {
exp <- capture_failure(expr)
if (is.null(exp)) {
fail("Expectation did not fail")
} else if (!is.null(message)) {
expect_match(exp$message, message, ...)
} else {
succeed()
}
invisible(NULL)
}
#' @export
#' @rdname expect_success
expect_snapshot_failure <- function(expr) {
expect_snapshot_error(expr, "expectation_failure")
}
#' @export
#' @rdname expect_success
expect_no_failure <- function(expr) {
exp <- capture_failure(expr)
if (!is.null(exp)) {
fail("Expectation failed")
} else {
succeed()
}
invisible(NULL)
}
expect_snapshot_skip <- function(x, cran = FALSE) {
expect_snapshot_error(x, class = "skip", cran = cran)
}
expect_no_skip <- function(code) {
expect_no_condition(code, class = "skip")
}
#' @export
#' @rdname expect_success
show_failure <- function(expr) {
exp <- capture_expectation(expr)
if (!is.null(exp) && expectation_failure(exp)) {
cat(cli::style_bold("Failed expectation:\n"))
cat(exp$message, "\n", sep = "")
}
invisible()
}
expect_snapshot_reporter <- function(reporter, paths = test_path("reporters/tests.R")) {
local_options(rlang_trace_format_srcrefs = FALSE)
local_rng_version("3.3")
set.seed(1014)
# withr::local_seed(1014)
expect_snapshot_output(
with_reporter(reporter, {
for (path in paths) test_one_file(path)
})
)
}
# to work around https://github.com/r-lib/withr/issues/167
local_rng_version <- function(version, .local_envir = parent.frame()) {
withr::defer(RNGversion(as.character(getRversion())), envir = .local_envir)
suppressWarnings(RNGversion(version))
}
# Use specifically for testthat tests in order to override the
# defaults found when starting the reporter
local_output_override <- function(width = 80, crayon = TRUE, unicode = TRUE,
.env = parent.frame()) {
reporter <- get_reporter()
if (is.null(reporter)) {
return()
}
old_width <- reporter$width
old_crayon <- reporter$crayon
old_unicode <- reporter$unicode
reporter$width <- width
reporter$crayon <- crayon
reporter$unicode <- unicode
withr::defer({
reporter$width <- old_width
reporter$crayon <- old_crayon
reporter$unicode <- old_unicode
}, .env)
}
|
