R/error.R

Defines functions getTraceback tryKeepTraceback vwc.error.traceback vwc.warnings.tracebacks vwc.messages.tracebacks vwc.tracebacks vwc.n.warnings vwc.n.messages vwc.n vwc.error vwc.warnings vwc.messages vwc.messages.conditions vwc.warnings.conditions vwc.error.condition vwc.conditions vwc.is.error vwc.value tryKeepConditions

Documented in getTraceback tryKeepConditions tryKeepTraceback vwc.conditions vwc.error vwc.error.condition vwc.error.traceback vwc.is.error vwc.messages vwc.messages.conditions vwc.messages.tracebacks vwc.n vwc.n.messages vwc.n.warnings vwc.tracebacks vwc.value vwc.warnings vwc.warnings.conditions vwc.warnings.tracebacks

## The tryKeepTraceback and getTraceback functions are stolen from HTSeqGenie
## Authors are I think Gregoire Pau and/or Jens Reeder
## Then modified and the other stuff by me, Brad Friedman

##' Try-catch wrapper, keeping error traceback and conditions
##'
##' This is a try-catch wrapper. It returns a list with
##' four elements:
##' \describe{
##'   \item{\code{$value}}{The value of the evaluated expression, or NULL if an error was thrown and execution did not complete}
##'   \item{\code{$messages}}{A list of \code{message} objects, each being a message thrown during the execution, in order}
##'   \item{\code{$warnings}}{A list of \code{condition} objects, each being a message thrown during the execution, in order}
##'   \item{\code{$error}}{NULL if there was no error, otherwise the \code{error} object, which can then be passed to \code{getTraceback}
##'         to retrieve the error}
##' }
##'
##' The elements of the \code{$messages}, \code{$warnings} and \code{$error} are all actually two-element lists, the first being
##' the condition object itself (named \code{$message}, \code{$warning} or \code{$error}) and the second begin the call stack
##' as returned by \code{sys.calls()} and named \code{$calls}.
##' 
##' The class of this object is set as "AnalysisPageValueWithConditions"
##' @title tryKeepConditions
##' @param expr Expression to evaluate
##' @return AnalysisPageValueWithConditions
##' @author Brad Friedman
##' @seealso \code{vwc.is.error}
##' @export
##' @seealso \code{\link{vwc.conditions}} \code{\link{vwc.error}} \code{\link{vwc.error.condition}} \code{\link{vwc.error.traceback}} \code{\link{vwc.is.error}} \code{\link{vwc.messages}} \code{\link{vwc.messages.conditions}} \code{\link{vwc.messages.tracebacks}} \code{\link{vwc.n}} \code{\link{vwc.n.messages}} \code{\link{vwc.n.warnings}} \code{\link{vwc.tracebacks}} \code{\link{vwc.value}} \code{\link{vwc.warnings}} \code{\link{vwc.warnings.conditions}} \code{\link{vwc.warnings.tracebacks}}
##' @aliases AnalysisPageValueWithConditions
##' @examples
##' value.with.warning <- tryKeepConditions({warning("warning message"); 3})
##' value.with.error <- tryKeepConditions({stop("err message")})
tryKeepConditions <- function(expr)  {
  conditions <- list(messages = list(),
                     warnings = list(),
                     error = NULL)
  value <- withCallingHandlers(tryKeepTraceback(expr),
                               message = function(m)  {
                                 conditions$messages <<- c(conditions$messages, list(list(message = m, calls = sys.calls())))
                                 invokeRestart("muffleMessage")
                               },
                               warning = function(w)  {
                                 conditions$warnings <<- c(conditions$warnings, list(list(warning = w, calls = sys.calls())))
                                 invokeRestart("muffleWarning")
                               })

  if(is(value, "try-error"))  {
    conditions$error <- value
    value <- NULL
  }

  ## This list(value = value) is important.
  ## If value is not a list then you can get away with just c(value = value, conditions)
  ## but if it is a list then it will be concatenated at the top level, so you will get
  ## a surprise where all the elements of value are there at the top level along with
  ## the conditions elements.
  retval <- c(list(value = value),
              conditions)

  ## Remove the last call from the stack, which is always going to be just function(m) or function(w)
  ## from the handler function
  for(condition.type in c("messages", "warnings"))
    retval[[condition.type]] <- lapply(retval[[condition.type]], function(cond)  {
      cond$calls[[length(cond$calls)]] <- NULL
      cond
    })
  class(retval) <- "AnalysisPageValueWithConditions"

  return(retval)
}

##' Get value of any AnalysisPageValueWithConditions
##'
##' Get value of any AnalysisPageValueWithConditions. If an error was thrown
##' then the value will be NULL.
##' @title vwc.value
##' @param vwc AnalysisPageValueWithConditions
##' @return Value of original evaluated expression, or NULL if an error was thrown.
##' @author Brad Friedman
##' @export
##' @examples
##' vwc <- tryKeepConditions({3+5})
##' vwc.value(vwc)
vwc.value <- function(vwc)  {
  stopifnot(is(vwc, "AnalysisPageValueWithConditions"))
  return(vwc$value)
}


##' Predicate to test if an AnalysisPageValueWithConditions had an error
##'
##' Predicate to test if an AnalysisPageValueWithConditions had an error
##' @title vwc.is.error
##' @param vwc AnalysisPageValueWithConditions, as returned by \code{\link{tryKeepConditions}}
##' @return Logical
##' @author Brad Friedman
##' @export
##' @examples
##' vwc <- tryKeepConditions({3+5})
##' vwc.is.error(vwc)
##'
##' vwc <- tryKeepConditions({stop("error!")})
##' vwc.is.error(vwc)
vwc.is.error <- function(vwc)  {
  stopifnot(is(vwc, "AnalysisPageValueWithConditions"))
  is(vwc$error, "try-error")
}


##' Return condition object(s) for an AnalysisPageValueWithConditions
##'
##' Return condition object(s) for an AnalysisPageValueWithConditions
##' @title vwc.conditions
##' @param vwc AnalysisPageValueWithConditions
##' @param type "messages" "warnings" or "error"
##' @return List of condition objects for "messages" or "warnings"
##' or a single condition object or NULL for "error".
##' @author Brad Friedman
##' @export
##' @seealso \code{\link{vwc.error.condition}},
##' \code{\link{vwc.messages.conditions}},
##' \code{\link{vwc.warnings.conditions}}
##' @examples
##' vwc <- tryKeepConditions({message("whatever"); warning("warning message"); 3})
##' vwc.conditions(vwc, "messages")
##' vwc.conditions(vwc, "warnings")
##' vwc.conditions(vwc, "error")
vwc.conditions <- function(vwc, type = "messages")  {
  stopifnot(is(vwc, "AnalysisPageValueWithConditions"))
  stopifnot(type %in% c("messages", "warnings", "error"))
  if(type == "error")  {
    return(vwc$error[[1]])
  }  else  {
    lapply(vwc[[type]], "[[", 1)
  }
}

##' Get condition object for error
##'
##' Get condition object for error
##' @title vwc.error.condition
##' @param vwc AnalysisPageValueWithCondition
##' @return condition object for error, or NULL
##' @author Brad Friedman
##' @export
##' @examples
##' vwc <- tryKeepConditions({stop("error!")})
##' vwc.error.condition(vwc)
vwc.error.condition <- function(vwc)  {
  vwc.conditions(vwc, "error")
}

##' Get condition object for warnings
##'
##' Get condition object for warnings
##' @title vwc.warnings.conditions
##' @param vwc AnalysisPageValueWithCondition
##' @return List of condition object for warnings (might be of length 0 if
##' no warnings were thrown).
##' @author Brad Friedman
##' @export
##' @examples
##' vwc <- tryKeepConditions({warning("I'm warning you!")})
##' vwc.warnings.conditions(vwc)
vwc.warnings.conditions <- function(vwc)  {
  vwc.conditions(vwc, "warnings")
}

##' Get condition object for messages
##'
##' Get condition object for messages
##' @title vwc.messages.conditions
##' @param vwc AnalysisPageValueWithCondition
##' @return List of condition objects for messages (might be of length 0)
##' @author Brad Friedman
##' @export
##' @examples
##' vwc <- tryKeepConditions({message("I've got something to say.")})
##' vwc.messages.conditions(vwc)
vwc.messages.conditions <- function(vwc)  {
  vwc.conditions(vwc, "messages")
}

##' Return condition Messages for an AnalysisPageValueWithConditions
##'
##' Return condition Messages for an AnalysisPageValueWithConditions.
##' @title vwc.messages
##' @param vwc AnalysisPageValueWithConditions
##' @param type Type of conditions. Must be "messages" or "warnings".
##' Default: messages.
##' @return Charvec of message strings
##' @author Brad Friedman
##' @export
##' @examples
##' vwc <- tryKeepConditions({message("I've got something to say.")})
##' vwc.messages(vwc)
vwc.messages <- function(vwc, type="messages")  {
  stopifnot(is(vwc, "AnalysisPageValueWithConditions"))
  stopifnot(type %in% c("messages", "warnings", "error"))

  if(type == "error")  {
    return(conditionMessage(vwc$error$error))
  }  else  {
    mesgs <- sapply(vwc[[type]], function(cond) conditionMessage(cond[[1]]))
    if(length(mesgs) > 0)  {
      return(mesgs)
    }  else  {
      ## If there are no messages then the sapply will return list(),
      ## but we want to always return a charvec
      return(character(0))
    }
              
  }
}




##' Access warning messages from AnalysisPageValueWithConditions
##'
##' Access warning messages from AnalysisPageValueWithConditions
##' @title vwc.warnings
##' @param vwc AnalysisPageValueWithConditions
##' @return Charvec of warning messages
##' @author Brad Friedman
##' @export
##' @examples
##' vwc <- tryKeepConditions({warning("I'm warning you!"); warning("Again")})
##' vwc.warnings(vwc)
vwc.warnings <- function(vwc)  vwc.messages(vwc, "warnings")

##' Access error message from AnalysisPageValueWithConditions
##'
##' Access error message from AnalysisPageValueWithConditions
##' @title vwc.error
##' @param vwc AnalysisPageValueWithConditions
##' @return Charvec of warning messages
##' @author Brad Friedman
##' @export
##' @examples
##' vwc <- tryKeepConditions({stop("This isn't going to work")})
##' vwc.error(vwc)
vwc.error <- function(vwc)  vwc.messages(vwc, "error")


##' Get number of conditions of a given type for an AnalysisPageValueWithConditions
##'
##' Get number of conditions of a given type for an AnalysisPageValueWithConditions.
##' @title vwc.n
##' @param vwc AnalysisPageValueWithConditions
##' @param type "messages", "warnings" or "error"
##' @return Number of conditions. (For "error" it can only be 0 or 1, and is equivalent
##' to calling \code{as.integer(\link{vwc.is.error}())}).
##' @author Brad Friedman
##' @export
##' @examples
##' vwc <- tryKeepConditions({stop("This isn't going to work")})
##' vwc.n(vwc, "error")
vwc.n <- function(vwc, type)  {
  stopifnot(is(vwc, "AnalysisPageValueWithConditions"))
  stopifnot(type %in% c("messages", "warnings", "error"))
  return(length(vwc[[type]]))
}

##' Get number of messages for an AnalysisPageValueWithConditions
##'
##' Get number of messages for an AnalysisPageValueWithConditions
##' @title vwc.n.messages
##' @param vwc AnalysisPageValueWithConditions
##' @return Non-negative Integer
##' @author Brad Friedman
##' @export
##' @examples
##' vwc <- tryKeepConditions({message("Message")})
##' vwc.n.messages(vwc)
vwc.n.messages <- function(vwc) vwc.n(vwc, "messages")

##' Get number of warnings for an AnalysisPageValueWithConditions
##'
##' Get number of warnings for an AnalysisPageValueWithConditions
##' @title vwc.n.warnings
##' @param vwc AnalysisPageValueWithConditions
##' @return Non-negative Integer
##' @author Brad Friedman
##' @export
##' @examples
##' vwc <- tryKeepConditions({warning("I'm warning you.")})
##' vwc.n.warnings(vwc)
vwc.n.warnings <- function(vwc) vwc.n(vwc, "warnings")


##' Return traceback(s) for an AnalysisPageValueWithConditions
##'
##' Return traceback(s) for an AnalysisPageValueWithConditions
##' @title vwc.tracebacks
##' @param vwc AnalysisPageValueWithConditions
##' @param type Type of conditions. Must be "messages", "warnings" or "error".
##' Default: "messages". A (new) error is thrown if type is "error" but
##' the \code{vwc} is not an error (that is, does not have an error, or
##' more specifically, \code{!vwc.is.error(vwc)}).
##' @return For "messages" or "warnings" it gives
##' a list of Charvecs of tracebacks, as built by \code{\link{getTraceback}}.
##' For "error" it only gives a single charvec, since there is only one error.
##' @author Brad Friedman
##' @export
##' @examples
##' f <- function(msg)  {
##'   warning(msg)
##' }
##' vwc <- tryKeepConditions({
##'   f("foo")
##'   f("bar")
##' })
##' vwc.tracebacks(vwc, "warnings")
vwc.tracebacks <- function(vwc, type="messages")  {
  stopifnot(is(vwc, "AnalysisPageValueWithConditions"))
  stopifnot(type %in% c("messages", "warnings", "error"))

  if(type == "error")  {
    stopifnot(vwc.is.error(vwc))
    tb <- getTraceback(vwc$error)
    return(tb)
  }  else  {
    tbs <- lapply(vwc[[type]], function(cond) getTraceback(cond))
    return(tbs)
  }
}

##' Get list of messages tracebacks
##'
##' Get list of tracebacks for messages.
##' @title vwc.messages.tracebacks
##' @param vwc AnalysisPageValueWithConditions
##' @return List of charvecs.
##' @author Brad Friedman
##' @export
##' @seealso \code{\link{vwc.tracebacks}}
##' @examples
##' f <- function(msg)  {
##'   message(msg)
##' }
##' vwc <- tryKeepConditions({
##'   f("foo")
##'   f("bar")
##' })
##' vwc.messages.tracebacks(vwc)
vwc.messages.tracebacks <- function(vwc)  vwc.tracebacks(vwc, "messages")

##' Get list of warnings tracebacks
##'
##' Get list of tracebacks for warnings.
##' @title vwc.warnings.tracebacks
##' @param vwc AnalysisPageValueWithConditions
##' @return List of charvecs.
##' @author Brad Friedman
##' @export
##' @seealso \code{\link{vwc.tracebacks}}
##' @examples
##' f <- function(msg)  {
##'   warning(msg)
##' }
##' vwc <- tryKeepConditions({
##'   f("foo")
##'   f("bar")
##' })
##' vwc.warnings.tracebacks(vwc)
vwc.warnings.tracebacks <- function(vwc)  vwc.tracebacks(vwc, "warnings")



##' Get traceback for error
##'
##' Get traceback for error
##' @title vwc.error.traceback
##' @param vwc AnalysisPageValueWithConditions
##' @return Charvecs, or NULL if there was no error.
##' (In this it differs from \code{\link{vwc.tracebacks}}, which
##'  throws an error).
##' @author Brad Friedman
##' @export
##' @seealso \code{\link{vwc.tracebacks}}
##' @examples
##' f <- function(msg)  {
##'   stop(msg)
##' }
##' vwc <- tryKeepConditions({
##'   f("foo")
##' })
##' vwc.error.traceback(vwc)
vwc.error.traceback <- function(vwc)  {
  if(vwc.is.error(vwc))  {
    return(vwc.tracebacks(vwc, "error"))
  }  else  {
    return(NULL)
  }
}




##' Wrapper around try-catch
##'
##' @title tryKeepTraceback
##' @param expr Expression to evaluate
##' @return Result of expression or error if thrown
##' @export
##' @examples
##' x <- tryKeepTraceback(stop("no way"))
##' if(is(x, "try-error"))  cat(getTraceback(x))
tryKeepTraceback <- function(expr) {
  withRestarts(withCallingHandlers(expr,
                                   error=function(e) {
                                     error <- e
                                     calls <- sys.calls()
                                     invokeRestart("myAbort", e, calls)
                                   }),
               myAbort=function(e, calls){
                 err <- list(error=e, calls=calls)
                 class(err) <- c("try-error")
                 return(err)
               })
}

##' Get traceback from tryKeepTraceback()
##'
##' @title getTraceback
##' @param mto An object of the try-error class
##' @return Traceback as a string
##' @export
##' @examples
##' x <- tryKeepTraceback(stop("no way"))
##' if(is(x, "try-error"))  cat(getTraceback(x))
getTraceback <- function(mto) {
  ## get trace
  trace <- lapply(mto$calls, function(call) {
    z = format(call)[1]
    attr(z, "srcref") <- attr(call, "srcref")
    z
  })
  
  ## reverse trace
  trace <- trace[length(trace):1]

  ## skip error handler calls
  skipFunctions <- c("withRestarts", "withCallingHandlers", "invokeRestart", "withOneRestart",
                     "tryKeepTraceback",
                     "tryKeepConditions",
                     "signalCondition",
                     ".signalSimpleWarning",
                     "doWithOneRestart", ".handleSimpleError", "simpleError",
                     "doTryCatch", "tryCatchOne", "tryCatchList", "tryCatch", "sendMaster")
  utrace <- unlist(trace)
  z <- unique(unlist(sapply(1:length(skipFunctions), function(i) grep(skipFunctions[i], utrace))))
  trace <- trace[-z]

  ## build trace using traceback()
  capture.output(traceback(trace))
}

Try the AnalysisPageServer package in your browser

Any scripts or data that you put into this service are public.

AnalysisPageServer documentation built on April 28, 2020, 6:32 p.m.