R/log_warnings.R

In iAM-AMR/sawmill: Process Queries from the CEDAR Database

#' @title
#'   Log Warning Messages in the Console
#'
#' @description
#'  The \code{log_warnings()} function prints any warning messages or errors generated by
#'  the enclosed expression to the console. Besides the message text itself, the
#'  date and timestamp are displayed, in an easy-to-read, Java-like format. If a warning
#'  is the result of faulty input data, the exact cell locations responsible are indicated.
#'  It was adapted from https://stackoverflow.com/questions/1975110/printing-stack-trace-and-continuing-after-error-occurs-in-r.
#'  The original function was written by Alice Purcell (https://stackoverflow.com/users/125663/alice-purcell),
#'  distributed to Stack Overflow with permission from the Man Group.
#'
#' @param expr
#'    line(s) of code, any warnings generated by which will be logged in the format
#'    facilitated by \code{log_warnings}
#'
#' @export


log_warnings <- function(expr, silentSuccess = FALSE, stopIsFatal = TRUE) {
  hasFailed <- FALSE
  messages <- list()
  warnings <- list()
  logger <- function(obj) {
    # Change behaviour based on type of message
    level <- sapply(class(obj), switch,
      debug = "DEBUG", message = "INFO", warning = "WARN", caughtError = "ERROR",
      error = if (stopIsFatal) "FATAL" else "ERROR", ""
    )
    level <- c(level[level != ""], "ERROR")[1]
    simpleMessage <- switch(level,
      DEBUG = ,
      INFO = TRUE,
      FALSE
    )
    quashable <- switch(level,
      DEBUG = ,
      INFO = ,
      WARN = TRUE,
      FALSE
    )

    # Format message
    time <- format(Sys.time(), "%Y-%m-%d %H:%M:%OS3")
    txt <- conditionMessage(obj)
    if (!simpleMessage) txt <- paste(txt, "\n", sep = "")
    msg <- paste(time, level, txt, sep = " ")

    # Output message
    if (silentSuccess && !hasFailed && quashable) {
      messages <<- append(messages, msg)
      if (level == "WARN") warnings <<- append(warnings, msg)
    } else {
      if (silentSuccess && !hasFailed) {
        cat(paste(messages, collapse = ""))
        hasFailed <<- TRUE
      }
      cat(msg)
    }

    # Muffle any redundant output of the same message
    optionalRestart <- function(r) {
      res <- findRestart(r)
      if (!is.null(res)) invokeRestart(res)
    }
    optionalRestart("muffleMessage")
    optionalRestart("muffleWarning")
  }
  vexpr <- withCallingHandlers(withVisible(expr),
    debug = logger, message = logger, warning = logger, caughtError = logger, error = logger
  )
  if (silentSuccess && !hasFailed) {
    cat(paste(warnings, collapse = ""))
  }
  if (vexpr$visible) vexpr$value else invisible(vexpr$value)
}