mirror of https://git.sr.ht/~hrbrmstr/splashr
boB Rudis
5 years ago
4 changed files with 136 additions and 14 deletions
@ -0,0 +1,90 @@ |
|||||
|
# Less cool counterparts to purrr's side-effect capture-rs |
||||
|
# |
||||
|
# Most of the helper functions are 100% from output.R in purrr repo |
||||
|
# |
||||
|
# @param quiet Hide errors (`TRUE`, the default), or display them |
||||
|
# as they occur? |
||||
|
# @param otherwise Default value to use when an error occurs. |
||||
|
# |
||||
|
# @return `safely`: wrapped function instead returns a list with |
||||
|
# components `result` and `error`. One value is always `NULL`. |
||||
|
# |
||||
|
# `quietly`: wrapped function instead returns a list with components |
||||
|
# `result`, `output`, `messages` and `warnings`. |
||||
|
# |
||||
|
# `possibly`: wrapped function uses a default value (`otherwise`) |
||||
|
# whenever an error occurs. |
||||
|
safely <- function(.f, otherwise = NULL, quiet = TRUE) { |
||||
|
function(...) capture_error(.f(...), otherwise, quiet) |
||||
|
} |
||||
|
|
||||
|
quietly <- function(.f) { |
||||
|
function(...) capture_output(.f(...)) |
||||
|
} |
||||
|
|
||||
|
possibly <- function(.f, otherwise, quiet = TRUE) { |
||||
|
force(otherwise) |
||||
|
function(...) { |
||||
|
tryCatch(.f(...), |
||||
|
error = function(e) { |
||||
|
if (!quiet) |
||||
|
message("Error: ", e$message) |
||||
|
otherwise |
||||
|
}, |
||||
|
interrupt = function(e) { |
||||
|
stop("Terminated by user", call. = FALSE) |
||||
|
} |
||||
|
) |
||||
|
} |
||||
|
} |
||||
|
|
||||
|
capture_error <- function(code, otherwise = NULL, quiet = TRUE) { |
||||
|
tryCatch( |
||||
|
list(result = code, error = NULL), |
||||
|
error = function(e) { |
||||
|
if (!quiet) |
||||
|
message("Error: ", e$message) |
||||
|
|
||||
|
list(result = otherwise, error = e) |
||||
|
}, |
||||
|
interrupt = function(e) { |
||||
|
stop("Terminated by user", call. = FALSE) |
||||
|
} |
||||
|
) |
||||
|
} |
||||
|
|
||||
|
capture_output <- function(code) { |
||||
|
warnings <- character() |
||||
|
wHandler <- function(w) { |
||||
|
warnings <<- c(warnings, w$message) |
||||
|
invokeRestart("muffleWarning") |
||||
|
} |
||||
|
|
||||
|
messages <- character() |
||||
|
mHandler <- function(m) { |
||||
|
messages <<- c(messages, m$message) |
||||
|
invokeRestart("muffleMessage") |
||||
|
} |
||||
|
|
||||
|
temp <- file() |
||||
|
sink(temp) |
||||
|
on.exit({ |
||||
|
sink() |
||||
|
close(temp) |
||||
|
}) |
||||
|
|
||||
|
result <- withCallingHandlers( |
||||
|
code, |
||||
|
warning = wHandler, |
||||
|
message = mHandler |
||||
|
) |
||||
|
|
||||
|
output <- paste0(readLines(temp, warn = FALSE), collapse = "\n") |
||||
|
|
||||
|
list( |
||||
|
result = result, |
||||
|
output = output, |
||||
|
warnings = warnings, |
||||
|
messages = messages |
||||
|
) |
||||
|
} |
Loading…
Reference in new issue