R/logging.R

In lindberg-m/contextendR: Analyse genomic data with regard to sequence contexts

# Minimal logging and error handling

# Handlers are included for:
#     debug, info, warnings and errors
#
# Three "global" variables can be set:
#     loglevel, logfile and tee
#
# Two interfaces are availeble:
#     handle_X and log_X
#
#  A timestamped message will be printed to console, file, or both,
#  depending on the global variables (tee for both file and console).
#  Messages will only be printed if the current loglevel is above the
#  threshold for that particular handler. Example: info-messages will
#  only be printed if the current loglevel is 3 or more, debug will be
#  printed if threshold is 4 or more, errors only need loglevel of 1.
#  Setting loglevel to 0 disables logging completely.
#
#  By default, error-handlers will print and exit the program,
#  but this behavior can be overridden by setting the flag `stop = FALSE`
#  to `handle_error` or `log.error`
#
#  The handle_X handlers will check if its first argument is true.
#  If not - the appropriate logger will be called. This is similar
#  to the `stopifnot` function, since the `handle_error` function
#  will, by default, also stop the program if the condition is not
#  met.
#
#  The log.X handlers will print whatever message is supplied using
#  the appropriate logger. As with handle_error, log.error will, by
#  default, also stop the program (override with `stop = FALSE`)


prefixes = c(
  ': [  Debug  ] :',
  ': [  Info   ] :',
  ': [ Warning ] :',
  ': [  Error  ] :'
)

logenv = new.env(parent = emptyenv())
logenv$LOGLEVEL = 2
logenv$LOGFILE = stderr()
logenv$TEE = FALSE
logenv$warnings = 0

#' Set loglevel
#'
#' Set loglevel threshold for logging and condition handling. The
#' different loglevels are: 
#' 0: Disable logging
#' 1: Show errors only
#' 2: Errors and warnings
#' 3: Errors, warnings and info
#' 4: Errors, warnings, info and debug
#' 
#' @param lvl Int. Loglevel. 0 - 4
#' @export
set_loglevel = function(lvl) {
  stopifnot(lvl >= 0) # 0 Turns logging off
  stopifnot(lvl <= 4)
  stopifnot(length(lvl) == 1)
  stopifnot(class(lvl) == "numeric")
  old_val = logenv$LOGLEVEL
  logenv$LOGLEVEL <- lvl
  invisible(old_val)
}

#' Set loggin Tee
#'
#' Put log in both console and file
#' @export
set_logging_tee = function() {
  old_val = logenv$TEE
  logenv$TEE <- TRUE
  invisible(old_val)
}

#' Get n warnings
#'
#' @export
get_n_warnings = function(){
  logenv$warnings
}

#' Reset n warnings
#'
#' @export
reset_n_warnings = function() {
  logenv$warnings = 0
}

#' Unset logging Tee
#'
#' Don't put log in both console and file
#' @export
unset_logging_tee = function() {
  old_val = logenv$TEE
  logenv$TEE <- FALSE
  invisible(old_val)
}

#' Set logfile
#'
#' Specify a file to use for logging. Will append if the file already exists.
#' @param path String. Path to file to use for logging
#' @export
set_logfile = function(path) {
  if (!(file.exists(path))) {
    file.create(path)
  } else {
    message(paste("Appending to already existing file:", path))
  }
  assign("LOGFILE", path, envir = logenv)
}

#' Set logfile
#'
#' Set stderr as log output
#' @export
unset_logfile = function() {
  assign("LOGFILE", stderr(), envir = logenv)
}

#' Get logging environment
#' @export
get_logenv = function() {
  sapply(ls(logenv), function(e) as.character(get(e, envir = logenv)))
}

#' Handle conditions and logging
#'
#' Minimal logging and error handling.
#' @param bool Boolean. If false - perform the logging
#' @param msg String. Message to log
#' @param stop Bool. Results in a call to `stop()` if condition is met for `handle_error`. Result in `stop()` for `log_error`
#' @param pfx Int. Prefix to use in log-output. Only used internally
#' @param retcode Int. Return code when `bool` is not met. Only used internally
#' @param threshold Int. Threshold to compare against the current logleve. Only used internally
#' @export
handle_condition = function(bool, msg, pfx = 1, retcode = 0, threshold = 2) {
  LOGLEVEL = get("LOGLEVEL", envir = logenv)
  LOGFILE  = get("LOGFILE", envir = logenv)
  LOGTEE   = get("TEE", envir = logenv)

  # Check the arguments to this function itself, and call it recursively if
  # format is incorrect
  bool_class  = class(bool)[1]
  bool_length = length(bool)
  if (bool_class != "logical") {
    errmsg = "The supplied condition passed to `handle_condition` is not of class 'logical'"
    handle_condition(FALSE, errmsg, pfx = 4, retcode = 1, threshold = 1)
    stop(errmsg)
  }

  if (bool_length == 0) {
    errmsg = "The supplied condition passed to `handle_condition` is of length 0"
    handle_condition(FALSE, errmsg, pfx = 4, retcode = 1, threshold = 1)
    stop(errmsg)
  }

  if (bool_length > 1) {
    warnmsg = paste("The supplied condition passed to `handle_condition` is of length", bool_length, "- Using first element only")
    handle_condition(FALSE, warnmsg, pfx = 3, retcode = 1, threshold = 1)
    warning(warnmsg)
    bool = bool[1]
  }

  # The actual handling is here
  if (threshold <= LOGLEVEL) {
    now = format(Sys.time(), "%Y-%m-%d %H:%M:%S")
    prefix = prefixes[pfx]
    message = paste(now, prefix, msg, "\n")
    if (!bool) {
      cat(message, file = LOGFILE, append = TRUE)
      if (LOGTEE && (LOGFILE != stderr())) {
        cat(message, file = stderr())
      }
      return(retcode)
    }
  }
  return(0)
}

#' @describeIn handle_condition Handle debug
#' @export
handle_debug = function(bool, msg) {
  handle_condition(bool, msg, pfx = 1,  retcode = 0, threshold = 4)
}

#' @describeIn handle_condition Handle info
#' @export
handle_info = function(bool, msg) {
  handle_condition(bool, msg, pfx = 2,  retcode = 0, threshold = 3)
}

#' @describeIn handle_condition Handle warning
#' @export
handle_warning = function(bool, msg) {
  w = handle_condition(bool, msg, pfx = 3,  retcode = 1, threshold = 2)
  if(w) logenv$warnings = logenv$warnings + 1
  w
}

#' @describeIn handle_condition Handle error
#' @export
handle_error = function(bool, msg, stop = TRUE) {
  retval = handle_condition(bool, msg, pfx = 4,  retcode = 1, threshold = 1)
  if (retval && stop) stop(call. = FALSE)
  return(retval)
}

#' @describeIn handle_condition Log debug
#' @export
log_debug = function(msg) {
  handle_condition(FALSE, msg, pfx = 1, retcode = 0, threshold = 4)
}

#' @describeIn handle_condition Log info
#' @export
log_info = function(msg) {
  handle_condition(FALSE, msg, pfx = 2, retcode = 0, threshold = 3)
}

#' @describeIn handle_condition Log warning
#' @export
log_warning = function(msg) {
  w = handle_condition(FALSE, msg, pfx = 3, retcode = 1, threshold = 2)
  if (w) logenv$warnings = logenv$warnings + 1
  w
}

#' @describeIn handle_condition Log error
#' @export
log_error = function(msg, stop = TRUE) {
  retval = handle_condition(FALSE, msg, pfx = 4, retcode = 1, threshold = 1)
  if (retval && stop) stop(call. = FALSE)
  return(retval)
}

# Can be used to incorporate testing to a function
handle_function_factory = function(f, handler, test, message) {
  function(...) {
    res = f(...)
    bool = test(res)
    ret_code = handler(bool, message)
    return(list(result = res, return_value = ret_code))
  }
}

#' Hanle possible errors and warnings
#'
#' Use the logging api for handling errors/warnings
#' for a specific function that might fail.
#'
#' @param f The function to wrap
#' @param errmsg String. The message to put if an error occurs
#' @param warnmsg String. The message to put if a warning occurs
#' @param stop Bool. Cause the script to stop after logging if error occurs?
#' @export
handle_try_catch = function(f, errmsg, warnmsg, stop = TRUE) {
  function(...){
    res = tryCatch(
      f(...),
      error = function(err) {
        err.msg = conditionMessage(err)
        log_error(paste(errmsg, "::", err.msg), stop = stop)
      },
      warning = function(warn) {
        warn.msg = conditionMessage(warn)
        log_warning(paste(warnmsg, "::", warn.msg))
      }
    )
    res
  }
}