app.R

library(shiny)
source('helper.R')

ui = fluidPage(
  plotOutput("i"),
  sliderInput(
    "s",
    "range",
    min = 0,
    max = 1000,
    value = 100
  ),
  actionButton("e", "error"),
  tableOutput('tblErrors'),
  tableOutput('tblErrorsOrig')
)

#
# Server app
#
server <- function(input, output) {
  #
  # Error handler inside observer
  #
  observeEvent(input$e, {
    errorHandler({
      f3('This will fail')
    })
  })
  
  output$i <- renderPlot({
    plot(rnorm(1:input$s))
  })
}

#
# Sample nested error
#
f1 <- function(m) {
  stop(m)
}

f2 <- function(m) {
  f1(m)
}

f3 <- function(m) {
  f2(m)
}
#
# Render a meaningful stack trace as table in ui, 
# in case of error.
#
errorHandler = function(expr, session = getDefaultReactiveDomain()) {
  options(show.error.locations = TRUE)
  tryCatch({
    #
    # Annotate stack trace info to be meaningful in getStackTraceDf 
    #
    captureStackTraces(eval(expr))
  }, error = function(e) {
    #
    # printStackTrace modified to output a data.frame 
    # to work with: write to file, DB, email.
    # Here, we just display the result in a table, client side.
    # 
    sysStack <-  getStackTraceDf(e)
    session$output$tblErrors <- renderTable({
      sysStack
    })
    #
    # Current methods seems to achieve this result
    #
    cond <- conditionStackTrace(e)
    sysStackOrig <- extractStackTrace(cond)
    session$output$tblErrorsOrig <- renderTable({
      sysStackOrig
    })
  })
}


shinyApp(ui, server)

app_simple.R

library(shiny)

ui = fluidPage(
  plotOutput("i"),
  sliderInput(
    "s",
    "range",
    min = 0,
    max = 1000,
    value = 100
    ),
  actionButton("e", "error"),
  tableOutput('tblErrorsSimple')
)

#
# Server app
#
server <- function(input, output) {
  #
  # Error handler inside observer
  #
  observeEvent(input$e, {
    errorHandler('Btn input error',{
      f3('This will fail')
    })
})

  output$i <- renderPlot({
    plot(rnorm(1:input$s))
  })
}

#
# Sample nested error
#
f1 <- function(m) {
  stop(m)
}

f2 <- function(m) {
  f1(m)
}

f3 <- function(m) {
  f2(m)
}

#' Handle error, simply
#'
#' @param {Character} label Label of the error handler
#' @param {Expression} expr Expression to evaluate. e.g. {print('hello')}
#' @return NULL
errorHandler <- function(label = NULL, expr, session=getDefaultReactiveDomain()){
  tryCatch({
    expr
  },
  error = function(e){
    #
    # Do something with messages, title and context, e.g.
    # write to a database or file. Or whatever.
    #
    out <- data.frame(
      level = 'error',
      message = e$message,
      call =  paste(deparse(e$call),collapse=" "),
      label = label
    )
    #
    # As an example, render into a table
    #
    if(!is.null(session)){
      session$output$tblErrorsSimple <- renderTable(out)
    }

  })
}

shinyApp(ui, server)

helper.R

#' Extract stack trace from cond, format it as a data.frame
#' 
#' @note  See https://github.com/rstudio/shiny/issues/2096
#' @param cond Cond object
getStackTraceDf <- function(cond,
  full = getOption("shiny.fullstacktrace", FALSE),
  offset = getOption("shiny.stacktraceoffset", TRUE)) {

  tryCatch({
    should_drop <- !full
    should_strip <- !full
    should_prune <- !full

    stackTraceCalls <- c(
      attr(cond, "deep.stack.trace", exact = TRUE),
      list(attr(cond, "stack.trace", exact = TRUE))
      )

    stackTraceParents <- lapply(stackTraceCalls, attr, which = "parents", exact = TRUE)
    stackTraceCallNames <- lapply(stackTraceCalls, shiny:::getCallNames)
    stackTraceCalls <- lapply(stackTraceCalls, shiny:::offsetSrcrefs, offset = offset)
   
    # Use dropTrivialFrames logic to remove trailing bits (.handleSimpleError, h)
    if (should_drop) {
      # toKeep is a list of logical vectors, of which elements (stack frames) to keep
      toKeep <- lapply(stackTraceCallNames, shiny:::dropTrivialFrames)
      # We apply the list of logical vector indices to each data structure
      stackTraceCalls <- mapply(stackTraceCalls, FUN = `[`, toKeep, SIMPLIFY = FALSE)
      stackTraceCallNames <- mapply(stackTraceCallNames, FUN = `[`, toKeep, SIMPLIFY = FALSE)
      stackTraceParents <- mapply(stackTraceParents, FUN = `[`, toKeep, SIMPLIFY = FALSE)
    }

    delayedAssign("all_true", {
      # List of logical vectors that are all TRUE, the same shape as
      # stackTraceCallNames. Delay the evaluation so we don't create it unless
      # we need it, but if we need it twice then we don't pay to create it twice.
      lapply(stackTraceCallNames, function(st) {
        rep_len(TRUE, length(st))
          })
      })

    # stripStackTraces and lapply(stackTraceParents, pruneStackTrace) return lists
    # of logical vectors. Use mapply(FUN = `&`) to boolean-and each pair of the
    # logical vectors.
    toShow <- mapply(
      if (should_strip) shiny:::stripStackTraces(stackTraceCallNames) else all_true,
      if (should_prune) lapply(stackTraceParents, shiny:::pruneStackTrace) else all_true,
      FUN = `&`,
      SIMPLIFY = FALSE
      )

    dfs <- mapply(seq_along(stackTraceCalls), rev(stackTraceCalls), rev(stackTraceCallNames), rev(toShow), FUN = function(i, calls, nms, index) {
      st <- data.frame(
        num = rev(which(index)),
        call = rev(nms[index]),
        loc = rev(shiny:::getLocs(calls[index])),
        category = rev(shiny:::getCallCategories(calls[index])),
        stringsAsFactors = FALSE
        )

      if (i != 1) {
        message("From earlier call:")
      }

      if (nrow(st) == 0) {
        message("  [No stack trace available]")
      } else {
        width <- floor(log10(max(st$num))) + 1
        formatted <- paste0(
          "  ",
          formatC(st$num, width = width),
          ": ",
          mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
            if (category == "pkg")
              crayon::silver(name)
            else if (category == "user")
              crayon::blue$bold(name)
            else
              crayon::white(name)}),
            "\n"
            )
      }
      return(st)
      }, SIMPLIFY = FALSE)
  },
  error=function(c){
    return(list(
        errInternal = c$message,
        errApp = cond$message
        ))
  }
  )
}