#' Error class
#'
#' @export
#' @template params
#' @param call. (logical) indicating if the call should become part
#' of the error message. Default: \code{FALSE}
#' @param message_template_verbose A verbose message template. optional.
#' use whisker templating. names to use are: reason, status, message.
#' use in template like \code{\{\{reason\}\}}, \code{\{\{status\}\}}, and
#' \code{\{\{message\}\}}. Note that this is ignored here, but is
#' used in the \code{HTTP*} methods (e.g. \code{HTTPBadRequest})
#' @param muffle (logical) whether to not respond when status codes
#' in 1xx-3xx series. Default: \code{FALSE}
#'
#' @details
#' \strong{Methods}
#' \itemize{
#' \item \code{do(response, mssg)} {
#'
#' Execute condition, whether it be message, warning, or error.
#'
#' \itemize{
#' \item response: is any response from \pkg{crul}, \pkg{curl}, or \pkg{httr}
#' Execute condition, whether it be message, warning, error, or your
#' own custom function. This method uses \code{message_template_verbose},
#' and uses it's default value.
#' \item mssg: character string message to include in call. ignored if
#' template does not have a \code{message} entry
#' }
#' }
#'
#' \item \code{set_behavior(behavior)}
#'
#' Set behavior, same as setting behavior on initializing with \code{$new()}
#' }
#'
#' @format NULL
#' @usage NULL
#'
#' @seealso \code{\link[fauxpas]{http}}, \code{\link[fauxpas]{Error-Classes}}
#'
#' @examples
#' Error$new()
#' # reset behavior
#' (z <- Error$new())
#' z$set_behavior("warning")
#' z
Error <- R6::R6Class(
"Error",
portable = TRUE,
public = list(
name = 'HTTP Error',
behavior = "stop",
call. = FALSE,
message_template = NULL,
message_template_verbose = NULL,
muffle = FALSE,
initialize = function(behavior = "stop", call. = FALSE, message_template,
message_template_verbose, muffle = FALSE) {
stopifnot(inherits(behavior, "character"))
if (!behavior %in% c('stop', 'warning', 'message')) {
stop("'behavior' must be one of stop, warning, or message",
call. = FALSE)
}
self$behavior <- behavior
private$behavior_type <- switch(
self$behavior, stop = "error", warning = "warning", message = "message")
if (!missing(call.)) self$call. <- call.
if (!missing(message_template)) {
if (!is.null(message_template)) {
if (!inherits(message_template, "character")) {
stop("'message_template' must be of class character",
call. = FALSE)
}
self$message_template <- message_template
}
}
if (missing(message_template)) {
self$message_template <- "{{reason}} (HTTP {{status}})"
}
if (!missing(message_template_verbose)) {
if (!is.null(message_template_verbose)) {
if (!inherits(message_template_verbose, "character")) {
stop("'message_template_verbose' must be of class character",
call. = FALSE)
}
self$message_template_verbose <- message_template_verbose
}
}
if (missing(message_template_verbose)) {
self$message_template_verbose <- "{{reason}} (HTTP {{status}}).\n - {{message}}"
}
self$muffle <- muffle
},
print = function(...) {
cat(sprintf("<%s>", self$name), sep = "\n")
cat(paste0(" behavior: ", self$behavior), sep = "\n")
cat(paste0(" message_template: ",
gsub("\n", "\\\\n", self$message_template)), sep = "\n")
cat(paste0(" message_template_verbose: ",
gsub("\n", "\\\\n", self$message_template_verbose)), sep = "\n")
invisible()
},
do = function(response, mssg = "", template = self$message_template) {
call <- if (self$call.) sys.call(-1) else NULL
stat <- private$fetch_status(response)
if (self$muffle) if (stat < 300) return(invisible(response))
eval(parse(text = self$behavior))(
private$make_condition(response, private$behavior_type, call, mssg, template)
)
},
set_behavior = function(behavior) {
stopifnot(inherits(behavior, "character"))
if (!behavior %in% c('stop', 'warning', 'message')) {
stop("'behavior' must be one of stop, warning, or message",
call. = FALSE)
}
self$behavior <- behavior
# and set behavior_type
private$behavior_type <- switch(
self$behavior, stop = "error", warning = "warning", message = "message")
}
),
private = list(
behavior_type = NULL,
make_condition = function(x, type, call, mssg, template) {
status <- private$fetch_status(x)
reason <- httpcode::http_code(status)$message
xx <- list(reason = reason, status = status, message = mssg)
message <- whisker::whisker.render(template, xx)
status_type <- (status %/% 100) * 100
http_class <- paste0("http_", unique(c(status, status_type,
"error")))
structure(list(message = message, call = call),
class = c(http_class, type, "condition"))
},
fetch_status = function(x) {
switch(
class(x)[1],
response = x$status_code, # httr
Response = x$status_code, # webmockr
VcrResponse = x$stats$status_code, # vcr
HttpResponse = x$status_code, # crul
list = x$status_code # curl
)
}
)
)
fetch_status <- function(x) {
switch(
class(x)[1],
response = x$status_code, # httr
Response = x$status_code, # webmockr
VcrResponse = x$stats$status_code, # vcr
HttpResponse = x$status_code, # crul
list = x$status_code # curl
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.