Display Error Instead of Plot in Shiny Web App

Display error instead of plot in Shiny web app

Have a look at validate, note that the example is taken from Write error messages for your UI with validate

rm(list = ls())
library(shiny)
runApp(list(
  ui = (fluidPage(

    titlePanel("Validation App"),

    sidebarLayout(
      sidebarPanel(
        selectInput("data", label = "Data set",
                    choices = c("", "mtcars", "faithful", "iris"))
      ),

      # Show a plot of the generated distribution
      mainPanel(
        tableOutput("table"),
        plotOutput("plot")
      )
    )
  )),
  server = function(input, output) {

    data <- reactive({ 
      validate(
        need(input$data != "", "Please select a data set")
      )
      get(input$data, 'package:datasets') 
    })

    output$plot <- renderPlot({
      hist(data()[, 1], col = 'forestgreen', border = 'white')
    })

    output$table <- renderTable({
      head(data())
    })

  }
))

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")
}

Plot in shiny display in viewer in R studio instead of web browser

This is one solution:

In the server, use reactive instead of renderPlot,

  plot<-reactive({           
  diamonds%>%filter(table==as.numeric(input$rok))%>%ggvis(~depth,~price)%>%layer_lines
  })

and bind the ggvis plot to shiny outside of the reactive statement:

plot%>% bind_shiny(plot_id="plot")

In the ui, your output in the main panel should then be:

      tabsetPanel(type="tab",
              tabPanel("plot",ggvisOutput("plot")),
              tabPanel("Vzorka raw dat",tableOutput("table"))

  )

Also note that, you don't need to library the packages in your ui.

Hope this helps

Errors in Shiny app due to reactivity difficulties

Below is a working version to adapt further for your needs. One overall recommendation is to start with a small working example before adding in more components/complexity.

Some of your errors came from how the data was being filtered. For example, you have:

filter(GaugeID == input$gauge1)

But GaugeID in the data frame shinydata2 is:

[1] "06814000" "06814000" "06814000" "06814000" "06814000" "06814000" 

But input$gauge1 has values from choices in the input, that came from the gaugeNames vector:

R> gaugeNames
 [1] "Turkey Creek near Seneca (06814000)"               "Soldier Creek near Delia (06889200)"              
 [3] "Marais Des Cygnes River near Reading (06910800)"   "Dragoon Creek near Burlingame (06911900)"         
 [5] "Chikaskia River near Corbin (07151500)"            "Cedar Creek near Cedar Point (07180500)"          
 [7] "Timber Creek near Collinsville (08050800)"         "North Fork Guadalupe River near Kyle (08171300)"  
 [9] "Blanco River near Kyle (08189500)"                 "Mission River at Refugio (08189500)"              
[11] "East Fork White River near Fort Apache (09492400)" "White River near Fort Apache (09494000)"          
[13] "Cibecue Creek near Chysotile (09497800)"           "Cherry Creek near Globe (09497980)"               
[15] "Los Gatos Creek near Coalinga (11224500)" 

So they will never match exactly, and filter was never keep any rows of data.

To get around this, you can use named vectors:

gaugeNames = c("Turkey Creek near Seneca (06814000)" = "06814000",
               "Soldier Creek near Delia (06889200)" = "06889200",
               "Marais Des Cygnes River near Reading (06910800)" = "06910800",
               ...

Then, when "Turkey Creek near Seneca (06814000)" is selected from the input, you will get the value of "06814000" which will match your GaugeID in your data frame.

You can also do this with varNames and the choices in your temporal1 radioButtons (as I have done below). This will help a lot in terms of reducing unnecessary code as well.

One other recommendation is consolidate a lot of your filter and select statements, so you have one reactive expression to get the data you need for your different outputs. I made shiny_data this expression - and to reference it, you use shiny_data().

Similarly, to call gaugeLoc from renderLeaflet you need to call it as gaugeLoc(). Also, the problem with the filter there is that x is omitted, and you need:

filter(x == input$gauge1)

To simplify the plots, you can have each renderPlot use the same data from a new reactive expression plot_data. Because you will want to use the input variables in group_by and summarise, you can use .data[[input$var]] convert the input string to a symbol for use in dplyr chain.

You will likely need to do more for the plots to get them working as you would like them to. But I hope this will be helpful in moving forward. Good luck!

library(shiny)
library(shinydashboard) 
library(lubridate) 
library(DT)
library(ggplot2) 
library(dplyr)
library(leaflet) 
library(tidyr) 

shinydata2 <- structure(list(GaugeID = c("06814000", "06814000", "06814000", 
"06814000", "06814000", "06814000"), DATE = structure(c(4018, 
4019, 4020, 4021, 4022, 4023), class = "Date"), YR = c(1981, 
1982, 1983, 1984, 1985, 1986), MNTH = c(1, 1, 1, 1, 1, 1), DY = c(1, 
2, 3, 4, 5, 6), PRCP = c(0, 0, 0, 0, 0, 0), TAIR = c(2.36, 0.71, 
-1.62, -7.365, -3.03, 0.185), PET = c(0.4185, 0.3206, 0.3215, 
0.3189, 0.3441, 0.4074), ET = c(0.4064, 0.31, 0.3102, 0.307, 
0.3308, 0.3909), OBS_RUN = c(0.0171, 0.0171, 0.0154, 0.0137, 
0.0137, 0.0154)), row.names = c(NA, -6L), class = c("tbl_df", 
"tbl", "data.frame"))

# Make this a named vector
varNames = c("Precipitation" = "PRCP", 
             "Air Temperature" = "TAIR",
             "Potential ET" = "PET", 
             "Actual ET" = "ET", 
             "Runoff" = "OBS_RUN")

years = unique(shinydata2$YR)

# If you need name of months, use "month.name"

gaugeIds = unique(shinydata2$GaugeID)

# Make this a named vector
gaugeNames = c("Turkey Creek near Seneca (06814000)" = "06814000",
               "Soldier Creek near Delia (06889200)" = "06889200",
               "Marais Des Cygnes River near Reading (06910800)" = "06910800",
               "Dragoon Creek near Burlingame (06911900)" = "06911900",
               "Chikaskia River near Corbin (07151500)" = "07151500",
               "Cedar Creek near Cedar Point (07180500)" = "07180500",
               "Timber Creek near Collinsville (08050800)" = "08050800",
               "North Fork Guadalupe River near Kyle (08171300)" = "08171300",
               "Blanco River near Kyle (08189500)" = "08189500",
               "Mission River at Refugio (08189500)" = "08189500",
               "East Fork White River near Fort Apache (09492400)" = "09492400",
               "White River near Fort Apache (09494000)" = "09494000",
               "Cibecue Creek near Chysotile (09497800)" = "09497800",
               "Cherry Creek near Globe (09497980)" = "09497980",
               "Los Gatos Creek near Coalinga (11224500)" = "11224500")

gaugeLat = as.numeric(c(39.94778, 39.23833, 38.56701, 38.71069, 37.12891,
                        38.19645, 33.55455, 30.0641, 29.97938, 28.29195, 
                        33.82227, 33.73644, 33.84311, 33.82783, 36.21468))
gaugeLong = as.numeric(c(-96.10862, -95.8886, -95.96163, -95.83603, -97.60144, 
                         -96.82458, -96.94723, -99.38699, -97.91, -97.27916, 
                         -109.81454, -110.16677, -110.55761, -110.85623, -120.47071))

gaugeLatLong = tibble(x = gaugeIds, y = gaugeLat, z = gaugeLong)

# Define user interface
ui = dashboardPage(
  dashboardHeader(title = "Test app"),    
  dashboardSidebar(
    selectizeInput(inputId = "gauge1", 
                   label = "Choose USGS Stream Gauge",
                   choices = gaugeNames),
    radioButtons(inputId = "variable1", 
                 label = "Choose variable",
                 choices = varNames),
    sliderInput(inputId = "yrRange1",
                label = "Select the range of years:",
                min = 1981, max = 2014,
                value = c(1981, 2000)),
    radioButtons(inputId = "temporal1",
                 label = "Temporal aggregation:",
                 choices = c("Annual" = "YR", "Monthly" = "MNTH"))
  ),
  dashboardBody(
    fluidRow(
      box(title = "Summary Statistics", 
          solidHeader = TRUE, 
          verbatimTextOutput("statsTable"),
          width = 5),
      box(leafletOutput("map"), width = 7)
    ),
    fluidRow(
      box(title = "Histogram",
          solidHeader = TRUE,
          plotOutput("histPlot"), width = 4),
      box(title = "Box Plot",
          solidHeader = TRUE, 
          plotOutput("boxPlot"),
          width = 4),
      box(title = "Time Series Plot",
          solidHeader = TRUE, 
          plotOutput("timePlot"), width = 4)
    )
  )
)  

######### Server

server = function(input, output) {
  
  shiny_data <- reactive({
    shinydata2 %>% 
      group_by(GaugeID, YR, MNTH) %>% 
      filter(GaugeID == input$gauge1,
             YR >= input$yrRange1[1],
             YR <= input$yrRange1[2]) %>%
      select(YR, MNTH, input$variable1)
  })
  
  output$statsTable = renderPrint({
    enframe(summary(shiny_data()[[input$variable1]]))
  })
  
  gaugeLoc <- reactive({ 
    gaugeLatLong %>% 
      filter(x == input$gauge1)
  })    
  
  output$map = renderLeaflet({
    leaflet(data = gaugeLoc()) %>% 
      addProviderTiles("Stamen.Watercolor") %>% 
      addMarkers(lng = ~z, lat = ~y, popup = ~x)
  })
  
  plot_data <- reactive({
    shiny_data() %>% 
      group_by(.data[[input$temporal1]]) %>% 
      summarise(total = sum(.data[[input$variable1]]), 
                mean = mean(.data[[input$variable1]]))
  })
  
  output$histPlot = renderPlot({
    ggplot(data = plot_data(), aes(x = total)) +
      geom_histogram(binwidth = 1)
  })
  
  output$timePlot = renderPlot({
    ggplot(data = plot_data(), aes(x = .data[[input$temporal1]], y = total)) +
        geom_line()
  })
  
  output$boxPlot = renderPlot({
    ggplot(data = plot_data(), aes(x = .data[[input$temporal1]], y = total)) +
        geom_boxplot()
  })
  
}

shinyApp(ui = ui, server = server)

R - time series plot displayed only in console, but not web app

You have to use the specific render and output functions of rAmCharts (renderAmCharts and amChartsOutput). It wont work with plotOutput.

library(shiny)
library(dplyr)
library(rAmCharts)

# source("C:\\Users\\wluo\\Desktop\\Garch\\app\\curncy basket.R")
data('data_stock_2')

ui <- fluidPage(mainPanel(
  # plotOutput(outputId = "weight.plot"))
  amChartsOutput("weight.plot", height = "600px")
  ))

server <- function(input, output) {
  output$weight.plot <- renderAmCharts({
    # date <- as.POSIXct(index(elasticd.w))
    # amTimeSeries(data.frame(date, coredata(elasticd.w)), "date", c("CNH", "NTN", "SGD", "EUR", "JPY"),
    #              groupToPeriods = c('hh', 'DD', '10DD'), main = "weights", legend = T, precision = 2)
    amTimeSeries(data_stock_2, 'date', c('ts1', 'ts2'))
  })
}

shinyApp(ui = ui, server = server)

if rows == 0 after filtering on inputs, have shiny app display custom message instead of plot

I was not using validate() correctly. This change gives the correct result:

validate(need(nrow(filtered)!=0, "There are no matches in the dataset. Try removing or relaxing one or more filters."))

---
title: "test"
output: 
  flexdashboard::flex_dashboard:
    theme: bootstrap
runtime: shiny
---

```{r setup, include=FALSE}
library(flexdashboard)
library(tidyverse)
library(tibbletime)
library(dygraphs)
library(magrittr)
library(xts)
```

```{r global, include=FALSE}
# generate data
set.seed(1)
dat <- data.frame(date = seq(as.Date("2018-01-01"), 
                             as.Date("2018-06-30"), 
                             "days"),
                  sex = sample(c("male", "female"), 181, replace=TRUE),
                  lang = sample(c("english", "spanish"), 181, replace=TRUE),
                  age = sample(20:35, 181, replace=TRUE))
dat <- dplyr::sample_n(dat, 80)
```

Sidebar {.sidebar}
=====================================

```{r}

radioButtons("diss", label = "Disaggregation",
             choices = list("All" = "Total",
                            "By Sex" = "sex",
                            "By Language" = "lang"), 
             selected = "Total")

sliderInput("agerange", label = "Age", 
              min = 15, 
              max = 99, 
              value = c(15, 99),
              step=1)
```

Page 1
=====================================

```{r plot}

# credit to https://stackoverflow.com/a/52325173/841405
renderDygraph({
  grp_col <- rlang::sym(input$diss) # This converts the input selection to a symbol

  filtered <- 
  dat %>%
    mutate(Total = 1) %>% # This is a hack to let us "group" by Total -- all one group
    filter(age >= input$agerange[1] & age <= input$agerange[2])

  validate(need(nrow(filtered)!=0, "There are no matches in the dataset. Try removing or relaxing one or more filters."))

  filtered %>%
    mutate(my_group = !!grp_col) %>%
    group_by(date = lubridate::floor_date(date, "1 week"), my_group) %>%

    count() %>% spread(my_group, n) %>% ungroup() %>%
    padr::pad() %>% replace(is.na(.), 0) %>%

    xts::xts(order.by = .$date) %>%
    dygraph() %>%
    dyRangeSelector() %>%
    dyOptions(
      useDataTimezone = FALSE, stepPlot = TRUE,
      drawGrid = FALSE, fillGraph = TRUE
    )
})
```

---

Related Topics