#' Test reporter: interactive progress bar of errors.
#'
#' @description
#' `ProgressReporter` is designed for interactive use. Its goal is to
#' give you actionable insights to help you understand the status of your
#' code. This reporter also praises you from time-to-time if all your tests
#' pass. It's the default reporter for [test_dir()].
#'
#' `ParallelProgressReporter` is very similar to `ProgressReporter`, but
#' works better for packages that want parallel tests.
#'
#' `CompactProgressReporter` is a minimal version of `ProgressReporter`
#' designed for use with single files. It's the default reporter for
#' [test_file()].
#'
#' @export
#' @family reporters
ProgressReporter <- R6::R6Class("ProgressReporter",
inherit = Reporter,
public = list(
show_praise = TRUE,
min_time = 1,
start_time = NULL,
last_update = NULL,
update_interval = NULL,
skips = NULL,
problems = NULL,
max_fail = NULL,
n_ok = 0,
n_skip = 0,
n_warn = 0,
n_fail = 0,
frames = NULL,
dynamic = FALSE,
ctxt_start_time = NULL,
ctxt_issues = NULL,
ctxt_n = 0,
ctxt_n_ok = 0,
ctxt_n_skip = 0,
ctxt_n_warn = 0,
ctxt_n_fail = 0,
ctxt_name = "",
file_name = "",
initialize = function(show_praise = TRUE,
max_failures = testthat_max_fails(),
min_time = 1,
update_interval = 0.1,
...) {
super$initialize(...)
self$capabilities$parallel_support <- TRUE
self$show_praise <- show_praise
self$max_fail <- max_failures
self$min_time <- min_time
self$update_interval <- update_interval
self$skips <- Stack$new()
self$problems <- Stack$new()
self$ctxt_issues <- Stack$new()
# Capture at init so not affected by test settings
self$frames <- cli::get_spinner()$frames
self$dynamic <- cli::is_dynamic_tty()
},
is_full = function() {
self$n_fail >= self$max_fail
},
start_reporter = function(context) {
self$start_time <- proc.time()
self$show_header()
},
start_file = function(file) {
self$file_name <- file
self$ctxt_issues <- Stack$new()
self$ctxt_start_time <- proc.time()
context_start_file(self$file_name)
},
start_context = function(context) {
self$ctxt_name <- context
self$ctxt_issues <- Stack$new()
self$ctxt_n <- 0L
self$ctxt_n_ok <- 0L
self$ctxt_n_fail <- 0L
self$ctxt_n_warn <- 0L
self$ctxt_n_skip <- 0L
self$ctxt_start_time <- proc.time()
self$show_status()
},
show_header = function() {
self$cat_line(
colourise(cli::symbol$tick, "success"), " | ",
colourise("F", "failure"), " ",
colourise("W", "warning"), " ",
colourise(" S", "skip"), " ",
colourise(" OK", "success"),
" | ", "Context"
)
},
status_data = function() {
list(
n = self$ctxt_n,
n_ok = self$ctxt_n_ok,
n_fail = self$ctxt_n_fail,
n_warn = self$ctxt_n_warn,
n_skip = self$ctxt_n_skip,
name = self$ctxt_name
)
},
show_status = function(complete = FALSE, time = 0, pad = FALSE) {
data <- self$status_data()
if (complete) {
if (data$n_fail > 0) {
status <- cli::col_red(cli::symbol$cross)
} else {
status <- cli::col_green(cli::symbol$tick)
}
} else {
# Do not print if not enough time has passed since we last printed.
if (!self$should_update()) {
return()
}
status <- spinner(self$frames, data$n)
if (data$n_fail > 0) {
status <- colourise(status, "failure")
} else if (data$n_warn > 0) {
status <- colourise(status, "warning")
}
}
col_format <- function(n, type) {
if (n == 0) {
if (type == "skip") {
" "
} else {
" "
}
} else {
if (type == "skip") {
colourise(sprintf("%2d", n), type)
} else {
colourise(n, type)
}
}
}
message <- paste0(
status, " | ",
col_format(data$n_fail, "fail"), " ",
col_format(data$n_warn, "warn"), " ",
col_format(data$n_skip, "skip"), " ",
sprintf("%3d", data$n_ok),
" | ", data$name
)
if (complete && time > self$min_time) {
message <- paste0(
message,
cli::col_grey(sprintf(" [%.1fs]", time))
)
}
if (pad) {
message <- strpad(message, self$width)
message <- cli::ansi_substr(message, 1, self$width)
}
if (!complete) {
message <- strpad(message, self$width)
self$cat_tight(self$cr(), message)
} else {
self$cat_line(self$cr(), message)
}
},
cr = function() {
if (self$dynamic) {
"\r"
} else {
"\n"
}
},
end_context = function(context) {
time <- proc.time() - self$ctxt_start_time
self$last_update <- NULL
# context with no expectation = automatic file context in file
# that also has manual contexts
if (self$ctxt_n == 0) {
return()
}
self$show_status(complete = TRUE, time = time[[3]])
self$report_issues(self$ctxt_issues)
if (self$is_full()) {
snapshotter <- get_snapshotter()
if (!is.null(snapshotter)) {
snapshotter$end_file()
}
stop_reporter(c(
"Maximum number of failures exceeded; quitting at end of file.",
i = "Increase this number with (e.g.) {.run testthat::set_max_fails(Inf)}"
))
}
},
add_result = function(context, test, result) {
self$ctxt_n <- self$ctxt_n + 1L
if (expectation_broken(result)) {
self$n_fail <- self$n_fail + 1
self$ctxt_n_fail <- self$ctxt_n_fail + 1
self$ctxt_issues$push(result)
self$problems$push(result)
} else if (expectation_skip(result)) {
self$n_skip <- self$n_skip + 1
self$ctxt_n_skip <- self$ctxt_n_skip + 1
self$skips$push(result)
} else if (expectation_warning(result)) {
self$n_warn <- self$n_warn + 1
self$ctxt_n_warn <- self$ctxt_n_warn + 1
self$ctxt_issues$push(result)
} else {
self$n_ok <- self$n_ok + 1
self$ctxt_n_ok <- self$ctxt_n_ok + 1
}
self$show_status()
},
end_reporter = function() {
self$cat_line()
colour_if <- function(n, type) {
colourise(n, if (n == 0) "success" else type)
}
self$rule(cli::style_bold("Results"), line = 2)
time <- proc.time() - self$start_time
if (time[[3]] > self$min_time) {
self$cat_line("Duration: ", sprintf("%.1f s", time[[3]]), col = "cyan")
self$cat_line()
}
skip_report(self)
if (self$problems$size() > 0) {
problems <- self$problems$as_list()
self$rule("Failed tests", line = 1)
for (problem in problems) {
self$cat_line(issue_summary(problem))
self$cat_line()
}
}
status <- summary_line(self$n_fail, self$n_warn, self$n_skip, self$n_ok)
self$cat_line(status)
if (self$is_full()) {
self$rule("Terminated early", line = 2)
}
if (!self$show_praise || stats::runif(1) > 0.1) {
return()
}
self$cat_line()
if (self$n_fail == 0) {
self$cat_line(colourise(praise(), "success"))
} else {
self$cat_line(colourise(encourage(), "error"))
}
},
report_issues = function(issues) {
if (issues$size() > 0) {
self$rule()
issues <- issues$as_list()
summary <- vapply(issues, issue_summary, FUN.VALUE = character(1))
self$cat_tight(paste(summary, collapse = "\n\n"))
self$cat_line()
self$rule()
}
},
should_update = function() {
if (self$update_interval == 0) {
return(TRUE)
}
if (identical(self$update_interval, Inf)) {
return(FALSE)
}
time <- proc.time()[[3]]
if (!is.null(self$last_update) &&
(time - self$last_update) < self$update_interval) {
return(FALSE)
}
self$last_update <- time
TRUE
}
)
)
testthat_max_fails <- function() {
val <- getOption("testthat.progress.max_fails")
if (is.null(val)) {
env <- Sys.getenv("TESTTHAT_MAX_FAILS")
val <- if (!identical(env, "")) as.numeric(env) else 10
}
val
}
#' @export
#' @rdname ProgressReporter
CompactProgressReporter <- R6::R6Class("CompactProgressReporter",
inherit = ProgressReporter,
public = list(
initialize = function(min_time = Inf, ...) {
super$initialize(min_time = min_time, ...)
},
start_file = function(name) {
if (!self$rstudio) {
self$cat_line()
self$rule(cli::style_bold(paste0("Testing ", name)), line = 2)
}
super$start_file(name)
},
start_reporter = function(context) {
},
end_context = function(context) {
if (self$ctxt_issues$size() == 0) {
return()
}
self$cat_line()
self$cat_line()
issues <- self$ctxt_issues$as_list()
summary <- vapply(issues, issue_summary, rule = TRUE,
FUN.VALUE = character(1)
)
self$cat_tight(paste(summary, collapse = "\n\n"))
self$cat_line()
},
end_reporter = function() {
had_feedback <- self$n_fail > 0 || self$n_warn > 0
if (self$n_skip > 0) {
if (!had_feedback) {
self$cat_line()
}
self$cat_line()
skip_report(self)
}
if (had_feedback) {
self$show_status()
self$cat_line()
} else if (self$is_full()) {
self$cat_line(" Terminated early")
} else if (self$n_skip == 0 && !self$rstudio) {
self$cat_line(cli::style_bold(" Done!"))
}
},
show_status = function(complete = NULL) {
self$local_user_output()
status <- summary_line(self$n_fail, self$n_warn, self$n_skip, self$n_ok)
self$cat_tight(self$cr(), status)
}
)
)
# parallel progres reporter -----------------------------------------------
#' @export
#' @rdname ProgressReporter
ParallelProgressReporter <- R6::R6Class("ParallelProgressReporter",
inherit = ProgressReporter,
public = list(
files = list(),
spin_frame = 0L,
is_rstudio = FALSE,
initialize = function(...) {
super$initialize(...)
self$capabilities$parallel_support <- TRUE
self$capabilities$parallel_updates <- TRUE
self$update_interval <- 0.05
self$is_rstudio <- Sys.getenv("RSTUDIO", "") == "1"
},
start_file = function(file) {
if (! file %in% names(self$files)) {
self$files[[file]] <- list(
issues = Stack$new(),
n_fail = 0L,
n_skip = 0L,
n_warn = 0L,
n_ok = 0L,
name = context_name(file),
start_time = proc.time()
)
}
self$file_name <- file
},
start_context = function(context) {
# we'll just silently ignore this
},
end_context = function(context) {
# we'll just silently ignore this
},
end_file = function() {
fsts <- self$files[[self$file_name]]
time <- proc.time() - fsts$start_time
# Workaround for https://github.com/rstudio/rstudio/issues/7649
if (self$is_rstudio) {
self$cat_tight(strpad(self$cr(), self$width + 1)) # +1 for \r
}
self$show_status(complete = TRUE, time = time[[3]], pad = TRUE)
self$report_issues(fsts$issues)
self$files[[self$file_name]] <- NULL
if (length(self$files)) self$update(force = TRUE)
},
end_reporter = function() {
self$cat_tight(self$cr(), strpad("", self$width))
super$end_reporter()
},
show_header = function() {
super$show_header()
self$update(force = TRUE)
},
status_data = function() {
self$files[[self$file_name]]
},
add_result = function(context, test, result) {
self$ctxt_n <- self$ctxt_n + 1L
file <- self$file_name
if (expectation_broken(result)) {
self$n_fail <- self$n_fail + 1
self$files[[file]]$n_fail <- self$files[[file]]$n_fail + 1L
self$files[[file]]$issues$push(result)
self$problems$push(result)
} else if (expectation_skip(result)) {
self$n_skip <- self$n_skip + 1
self$files[[file]]$n_skip <- self$files[[file]]$n_skip + 1L
self$skips$push(result)
} else if (expectation_warning(result)) {
self$n_warn <- self$n_warn + 1
self$files[[file]]$n_warn <- self$files[[file]]$n_warn + 1L
self$files[[file]]$issues$push(result)
} else {
self$n_ok <- self$n_ok + 1
self$files[[file]]$n_ok <- self$files[[file]]$n_ok + 1
}
},
update = function(force = FALSE) {
if (!force && !self$should_update()) return()
self$spin_frame <- self$spin_frame + 1L
status <- spinner(self$frames, self$spin_frame)
message <- paste(
status,
summary_line(self$n_fail, self$n_warn, self$n_skip, self$n_ok),
if (length(self$files) > 0) "@" else "Starting up...",
paste(context_name(names(self$files)), collapse = ", ")
)
message <- strpad(message, self$width)
message <- cli::ansi_substr(message, 1, self$width)
self$cat_tight(self$cr(), message)
}
)
)
# helpers -----------------------------------------------------------------
spinner <- function(frames, i) {
frames[((i - 1) %% length(frames)) + 1]
}
issue_header <- function(x, pad = FALSE) {
type <- expectation_type(x)
if (has_colour()) {
type <- colourise(first_upper(type), type)
} else {
type <- first_upper(type)
}
if (pad) {
type <- strpad(type, 7)
}
paste0(type, expectation_location(x, " (", ")"), ": ", x$test)
}
issue_summary <- function(x, rule = FALSE) {
header <- cli::style_bold(issue_header(x))
if (rule) {
header <- cli::rule(header, width = max(cli::ansi_nchar(header) + 6, 80))
}
paste0(header, "\n", format(x))
}
strpad <- function(x, width = cli::console_width()) {
n <- pmax(0, width - cli::ansi_nchar(x))
paste0(x, strrep(" ", n))
}
skip_report <- function(reporter, line = 1) {
n <- reporter$skips$size()
if (n == 0) {
return()
}
reporter$rule(paste0("Skipped tests (", n, ")"), line = line)
reporter$cat_line(skip_bullets(reporter$skips$as_list()))
reporter$cat_line()
}
skip_bullets <- function(skips) {
message <- map_chr(skips, "[[", "message")
message <- gsub("Reason: ", "", message)
message <- gsub(":?\n(\n|.)+", "", message) # only show first line
locs <- map_chr(skips, expectation_location)
locs_by_skip <- split(locs, message)
n <- lengths(locs_by_skip)
skip_summary <- map_chr(locs_by_skip, paste, collapse = ", ")
bullets <- paste0(
cli::symbol$bullet, " ", names(locs_by_skip), " (", n, "): ", skip_summary
)
cli::ansi_strwrap(bullets, exdent = 2)
}
#' Set maximum number of test failures allowed before aborting the run
#'
#' This sets the `TESTTHAT_MAX_FAILS` env var which will affect both the
#' current R process and any processes launched from it.
#'
#' @param n Maximum number of failures allowed.
#' @export
#' @keywords internal
set_max_fails <- function(n) {
Sys.setenv('TESTTHAT_MAX_FAILS' = n)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.