Shiny - Custom Warning/Error Messages

Shiny - custom warning/error messages?

As we need to return plot to renderPlot() we need to display the error/warning within plot() function.

We are plotting a blank scatter plot with "white" colour, then adding the error message with text() function in the middle - x=1, y=1 of the plot, see below working example:

#dummy dataframe
data <- data.frame(sites.id=rep(letters[1:3],10),particles=runif(30))

#subset - change "SiteX" to "a" to test ifelse
data <- data[data$sites.id=="SiteX", ]

if(nrow(data) == 0) {
  # print error/ warning message
  plot(1,1,col="white")
  text(1,1,"no data")
} else {
  # plot the data
  dens <- density(data$particles, na.rm = TRUE)
  plot(dens, main = paste("Histogram of", sites.id, "particles"), 
       xlab = "particles")
}

Hide error message with custom message or reactive button in Shiny App

Adding a validation to the reactive term lets you write custom error messages with conditional statements.

Sample Image

library(shiny)

mydata <- read.csv("https://stats.idre.ucla.edu/stat/data/binary.csv")

ui <- fluidPage(
  
  sidebarLayout(
    sidebarPanel(
      selectInput("input1", "Dependent Variable", choices = names(mydata)), 
      selectInput("input2", "Independent Variable(s)", choices = names(mydata), multiple = TRUE)
    ),
    mainPanel(
      verbatimTextOutput("output2"),
      verbatimTextOutput("output1")
    )
  )
)

server <- function(input, output) {
  
  left_vars <- reactive({
    validate(
      need(input$input1, "Please enter a dependant variable"))

      input$input1})
  
  right_vars <- reactive({
    validate(
      need(input$input2, "Please enter an independant variable"))
      
    rights = input$input2
    rights <- paste(rights, collapse=" + ")
  })
  
  log_formula <- reactive({as.formula(paste(left_vars(), " ~ ", right_vars()))})
  
  output$output1 <- renderPrint({summary(glm(formula = log_formula(), data = mydata, family = "binomial"))})
  
  output$output2 <- renderPrint({
    paste(paste0(left_vars(), " ~ ", right_vars()))
  })  
}

shinyApp(ui = ui, server = server)

Edit: In case you are wondering why it is displaying the same warning twice. It is because you have two render functions that can not be completed until an independent variable is selected.

Error message in Shiny from sourced R script

Use `withCallingHandlers()`

You can wrap your call to source() as follows and use arbitrary code to handle warnings and messages that arise when the code is run. To handle errors you will need to wrap this again in tryCatch() so your app doesn't crash. For example, you could choose to simply send notifications as follows:

tryCatch(
  withCallingHandlers(
    source(paste0(Code_loc,"GUI_trials2.r"), local = TRUE),
    message = function(m) showNotification(m$message, type = "message"),
    warning = function(w) showNotification(w$message, type = "warning")
  ),
  error = function(e) showNotification(e$message, type = "error")
)

You can test this by using something like the following code in your GUI_trials2.R script:

for (i in 1:3) {
  warning("This is warning ", i)
  Sys.sleep(0.5)
  message("This is message", i)
  Sys.sleep(0.5)
}

stop("This is a fake error!")

Streaming Output in New Window

The easiest way to do this is to pepper your GUI_trials2.R script with informative calls to message() and then use withCallingHandlers() to output these as above. If you want to be more sophisticated and show these messages in a new window, you could do this by updating a modalDialog(), though this would require the shinyjs package. Here is a basic example:

server = function(input, output) { 
  ME_DATE_GUI <- reactive({input$ME_DATE_output})
  
  # Show a modal that will be updated as your script is run
  observeEvent(input$calculate, {
    showModal(modalDialog(
      shinyjs::useShinyjs(),
      title = "Running my R script",
      div("You can put an initial message here", br(), id = "modal_status")
    ))
    
    Code_loc <- "K:/Codes/"
    ME_DATE <- ME_DATE_GUI()
    
    # Run the script and use `withCallingHandlers()` to update the modal.
    # add = TRUE means each message will be added to all the previous ones
    # instead of replacing them.
    tryCatch(
      withCallingHandlers(
        source(paste0(Code_loc,"GUI_trials2.r"), local = TRUE),
        message = function(m) {
          shinyjs::html("modal_status", paste(m$message, br()), add = TRUE)
        },
        warning = function(w) {
          shinyjs::html("modal_status", paste(w$message, br()), add = TRUE)
        }
      ),
      error = function(e) {
        shinyjs::html("modal_status", paste(e$message, br()), add = TRUE)
      }
    )
  }) 
}

Display Code From `source()`

The echo = TRUE argument to source() will mean that each expression in the file gets printed in the console. Unfortunately, applying handlers to text as it appears in the console isn't possible in R unless it's a message/warning/error, so echo = TRUE won't be of any use here. However, you could define a custom function, similar to source() which will allow you to handle the code as text before it gets evaluated. Here is an example:

# Default handler just prints the code to console, similar
# to `source(echo = TRUE)`
source2 <- function(file, handler = cli::cat_line, local = FALSE) {
  
  # Copy `source()` method of handling the `local` argument
  envir <- if (isTRUE(local)) 
    parent.frame()
  else if (isFALSE(local)) 
    .GlobalEnv
  else if (is.environment(local)) 
    local
  else stop("'local' must be TRUE, FALSE or an environment")
  
  # Read each 'expression' in the source file
  exprs <- parse(n = -1, file = file, srcfile = NULL, keep.source = FALSE)
  
  # Apply `handler()` to each expression as text, then 
  # evaluate the expression as code
  for (expr in exprs) {
    handler(deparse(expr))
    eval(expr, envir)
  }
  
  # Return nothing
  invisible()
  
}

This will allow you to do anything you like with the code text before
it gets evaluated. E.g. you could apply some pretty HTML formatting and
then output it as a message, which would allow you to use something very similar to the code above, since withCallingHandlers() would handle
these messages for you:

# Define a function to show a message as code-formatted HTML
html_message <- function(msg) {
  with_linebreaks <- paste(msg, collapse = "<br/>")
  as_code <- sprintf("<code>%s</code>", with_linebreaks)
  spaces_preserved <- gsub(" ", " ", as_code)
  message(spaces_preserved)
}

# Then use very similar code to the above for `server`, so 
# something like -
tryCatch(
      withCallingHandlers(
        source2(file = paste0(Code_loc,"GUI_trials2.r"), 
                handler = html_message,
                local = TRUE),
        # ... Same code as in the above example using normal source()

Bonus: Getting Fancy with HTML

If you want to get really fancy you could add some custom HTML formatting to each of your message/warning/error functions, e.g. you could show errors in red like so:

error = function(e) {
  shinyjs::html("modal_status", add = TRUE, sprintf(
    '<span style = "color: red;">%s</span><br/>', e$message
  ))
}

R Shiny, shinyapps.io printing error messages for R codes

use shinyCatch from spsComps

Example for your case:

library(shiny)
library(spsComps)
ui <- fluidPage(
  actionButton("a", "blocking"),
  actionButton("b", "no blocking"),
)

server <- function(input, output, session) {
    observeEvent(input$a, {
      spsComps::shinyCatch({
          seq(1,10,-2)
      },
      # blocking recommended
      blocking_level = "error",
      prefix = "My-project" #change console prefix if you don't want "SPS"
      )
      # some other following actions will NOT  be run 
      print("other actions")
    })
    
    # if you dont want to block
    observeEvent(input$b, {
        spsComps::shinyCatch({
            seq(1,10,-2)
        }, prefix = "My-project")
        # some other following actions will run 
        print("other actions")
    })
}

shinyApp(ui, server)

or try more demos here

In R Shiny, how to eliminate Warning: Error in if: argument is of length 0 from running reactive function?

Solved by reviewing similar post In R Shiny App, how to render a default table when first invoking the App? and with mnist's explanation: error occurs in vectorVariable() because when the app starts, this function is evaluated before input$showVectorBtn is created hence this value is NULL. I inserted the following default values to help with rendering a plot with when first invoking the App: matrix2Default <- vectorBase(15,0.2), and I replaced the yield <- function in the original MWE with the following tests for where things stand with user inputs:

 yield <- function(){
if(!isTruthy(input$base_input)){matrix2Default} else {
  if(!isTruthy(input$showVectorBtn)){vectorBase(input$periods,input$base_input[1,1])} else{
    vectorVariable(yield_input())
    } # close second else
  } # closes first else
} # close function

As mnist states, the code and functions are very convoluted. There are some irrelevant pieces of code in the original MWE, representing vestiges from the original code this MWE was stripped from. I will be working to simplify this code!

Below is complete working MWE that resolves the issue. Note that custom functions aren't repeated below as they are the same as in original post, EXCEPT don't forget to include the new matrix2Default function!!

ui <- pageWithSidebar(
  headerPanel("Model..."),
  sidebarPanel(uiOutput("Panels")), 
  mainPanel(
    tabsetPanel(
      tabPanel("Balances", value=2,
               fluidRow(
                 radioButtons(
                   inputId = 'Tab2',
                   label = h5(strong(helpText("View:"))),
                   choices = c('Vector plot'),
                   selected = 'Vector plot',
                   inline = TRUE
                 ) # close radio buttons
               ), # close fluid row
               conditionalPanel(condition="input.Tab2=='Vector plot'",plotOutput("graph1")),
      ),  # close tab panel
      id = "tabselected"
    ) # close tabset panel
  ) # close main panel
) # close page with sidebar

server <- function(input,output,session)({
  
  periods      <- reactive(input$periods)
  base_input   <- reactive(input$base_input)
  yield_input  <- reactive(input$yield_input)

  vectorVariable <- function(y){vectorMultiFinal(input$periods,matrixValidate(input$periods,y))}
  
  yield <- function(){
    if(!isTruthy(input$base_input)){matrix2Default} else {
      if(!isTruthy(input$showVectorBtn)){vectorBase(input$periods,input$base_input[1,1])} else{
        vectorVariable(yield_input())
        } # close second else
      } # closes first else
    } # close function
  
  output$Panels <- renderUI({
    tagList( 
      conditionalPanel(
        condition="input.tabselected==2",
        useShinyjs(),
        sliderInput('periods','Periods X:',min=1,max=30,value=15),
        helpText(strong('Change variable Y below:')),
        matrix1Input("base_input"),
        helpText(strong('Add curve to variable Y:')),
        actionButton('showVectorBtn','Show matrix below'), 
        actionButton('hideVectorBtn','Hide below matrix'),
        actionButton('resetVectorBtn','Reset below inputs'),
        hidden(uiOutput("Vectors"))
      ), # close conditional panel
    ) # close tagList
  }) # close renderUI
  
  observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
  observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})

  output$Vectors <- renderUI({
    input$resetVectorBtn
    matrix2Input("yield_input",input$periods,input$base_input[1,1])
  }) # close render UI
  
  output$graph1 <- renderPlot({vectorPlot(yield(),"","Period","Rate")})
  
}) # close server

Shiny - Custom Warning/Error Messages