Shiny app: Download data source outside of renderPlot for quicker user manipulation

Question

This is my first shiny app. I would like for the user to be able to update the number of facet columns and the dimensions of downloaded plot. readNWISuv, the function to download data can take a long time if multiple years are queried. Currently, the app downloads the data each time the user wants to change the plot format or plot dimensions. Not sure if I need to use reactiveValues, but I would assume that I want the data to be downloaded and manipulated outside of renderPlot. Thanks!

library(shiny)
library(dataRetrieval)
library(lubridate)
library(tidyverse)
library(plotly)

#flow wrecker
ui <- pageWithSidebar( #fluidPage(
   # Application title
   titlePanel("Flow Record"),

   # Sidebar with a date input 
   #sidebarLayout
      sidebarPanel(
        dateRangeInput("daterange", "Date range: (yyyy-mm-dd)",
                       start = Sys.Date()-10,
                       min = "1980-10-01"),
        textInput("gage", "USGS Gage #", "11532500"),
        #actionButton("dload","Download data"),
        selectInput("facet_x", "Facet Column #:", 2, choices =1:4),
        submitButton("Update View", icon("refresh")),
        helpText("When you click the button above, you should see",
                 "the output below update to reflect the values you",
                 "entered above:"),
        #verbatimTextOutput("value"),
        downloadButton('downloadImage', 'Download figure'),
        numericInput("fig_x", "Fig. Dim. x:", 10, min = 3, max = 16),
        numericInput("fig_y", "Fig. Dim. y:", 10, min = 3, max = 16),
        width = 3
      ),


      # Show a plot of the generated WY
   mainPanel(       
   plotlyOutput("WYfacet")
   )
)

# Define server draw WY facets
server <- function(input, output) {

  parameterCd <- "00060"  #  discharge
  #water year
  wtr_yr <- function(dates, start_month=10) {
    # Convert dates into POSIXlt
    dates.posix = as.POSIXlt(dates)
    # Year offset
    offset = ifelse(dates.posix$mon >= start_month - 1, 1, 0)
    # Water year
    adj.year = dates.posix$year + 1900 + offset
    # Return the water year
    adj.year
  }

  output$WYfacet <- renderPlotly({
     #progress bar
     withProgress(readNWISuv(input$gage, parameterCd, input$daterange[1], input$daterange[2],tz="America/Los_Angeles") %>% addWaterYear,
                  message = 'Download in progress',
                  detail = 'This may take a while...', value = 1)
     #download

    temperatureAndFlow <- readNWISuv(input$gage, parameterCd, input$daterange[1], input$daterange[2],tz="America/Los_Angeles") %>% addWaterYear
    names(temperatureAndFlow)<-c("agc","site","date","WY", "flow","a","tzone")
    temperatureAndFlow$commonDate <- as.Date(format(temperatureAndFlow$date, format="2000-%m-%d"))
    tf.df<-temperatureAndFlow %>% 
      filter(WY<=max(WY) & WY>=if_else(month(min(date))<10,min(WY)+1,min(WY)))
    tf.df$date.d<-format(tf.df$date, format="%Y-%m-%d")
    #mutate commonDate
    df4 <- tf.df %>%
      mutate(WY=factor(wtr_yr(date.d))) %>%
      #seq along dates starting with the beginning of your water year
      mutate(commonDate=as.Date(paste0(ifelse(month(date.d) < 10, "2001", "2000"),
                                       "-", month(date.d), "-", day(date.d))), Date=date.d)

    #plot

      ploty<-ggplot(data = df4,mapping = aes(x = commonDate, y = flow,label=Date, colour = factor(WY))) +
        geom_line() +
        labs(x = " ", y = "Discharge (cfs)") +
        facet_wrap(facets = ~WY,ncol=as.integer(input$facet_x)) +
        scale_y_log_eng()+
        annotation_logticks(sides = "l")+
        theme_bw()+
        theme(panel.grid.minor.x = element_blank())+
        scale_x_date(labels = function(x) format(x, "%b"),date_breaks = "1 months")+
        guides(colour=FALSE)

      ggplotly(ploty, tooltip=c("flow","Date"))


     })
     #fig dimensions
     output$fig_x <- renderText({ input$fig_x })
     output$fig_y <- renderText({ input$fig_y })
     #facet columns
     output$facet_x <- renderText({ input$facet_x })
     #download to computer
     output$downloadImage <- downloadHandler(
            filename = function(){paste("plot",'.png',sep='')},
            content = function(file){
              ggsave(file,width = input$fig_x,height = input$fig_y, dpi = 600, units = "in", device='png')
              print(ggplot(data = df4,mapping = aes(x = commonDate, y = flow, colour = factor(WY))) +
                      geom_line() +
                      #geom_point()+
                      #geom_vline(data = trip,aes(xintercept=commonDate),trip_df,color="black")+
                      labs(x = " ", y = "Discharge (cfs)") +
                      facet_wrap(facets = ~WY,ncol=as.integer(input$facet_x)) +
                      scale_y_log_eng()+
                      annotation_logticks(sides = "l")+
                      theme_bw()+
                      theme(panel.grid.minor.x = element_blank())+
                      scale_x_date(labels = function(x) format(x, "%b"),date_breaks = "1 months")+
                      guides(colour=FALSE))
                    })
}

# Run the application 
shinyApp(ui = ui, server = server)

Andy Baxter · Accepted Answer · 2019-12-03T20:44:05.153

There are a few changes to make to your sever section to make this work. Primarily:

splitting the creation of the dataframe into a new eventReactive function, dependent on an actionButton.
referring to the function inside the renderPlotly call

Try this:


## Within ui function call ############################################

# submitButton("Update View", icon("refresh")),  # line to replace
actionButton(inputId = "update", "Update View", icon("refresh")),

## (if you want to keep a  button to control when data is downloaded ##


server <- function(input, output) {

  parameterCd <- "00060"  #  discharge
  #water year
  wtr_yr <- function(dates, start_month=10) {
    # Convert dates into POSIXlt
    dates.posix = as.POSIXlt(dates)
    # Year offset
    offset = ifelse(dates.posix$mon >= start_month - 1, 1, 0)
    # Water year
    adj.year = dates.posix$year + 1900 + offset
    # Return the water year
    adj.year
  }

  # New part here - use `reactive` to make df4 a new thing, which is processed separately. The `eventReactive` function waits till it sees the button pressed.

  df4 <- eventReactive(input$update, ignoreNULL = FALSE, {
    #progress bar
    withProgress(readNWISuv(input$gage, parameterCd, input$daterange[1], input$daterange[2],tz="America/Los_Angeles") %>% addWaterYear,
                 message = 'Download in progress',
                 detail = 'This may take a while...', value = 1)
    #download

    temperatureAndFlow <- readNWISuv(input$gage, parameterCd, input$daterange[1], input$daterange[2],tz="America/Los_Angeles") %>% addWaterYear
    names(temperatureAndFlow)<-c("agc","site","date","WY", "flow","a","tzone")
    temperatureAndFlow$commonDate <- as.Date(format(temperatureAndFlow$date, format="2000-%m-%d"))
    tf.df<-temperatureAndFlow %>% 
      filter(WY<=max(WY) & WY>=if_else(month(min(date))<10,min(WY)+1,min(WY)))
    tf.df$date.d<-format(tf.df$date, format="%Y-%m-%d")

    #mutate commonDate
    tf.df %>%
      mutate(WY=factor(wtr_yr(date.d))) %>%
      #seq along dates starting with the beginning of your water year
      mutate(commonDate=as.Date(paste0(ifelse(month(date.d) < 10, "2001", "2000"),
                                       "-", month(date.d), "-", day(date.d))), Date=date.d)
  })


  output$WYfacet <- renderPlotly({

    # req will pause plot loading till new data downloaded above, but changes to display will render without new download
    req(df4())

    #plot
    ploty<-ggplot(data = df4(),  # Put brackets here to refer to df4 as a reactive input!!!
                  mapping = aes(x = commonDate, y = flow, label=Date, colour = factor(WY))) +
      geom_line() +
      labs(x = " ", y = "Discharge (cfs)") +
      facet_wrap(facets = ~WY,ncol=as.integer(input$facet_x)) +
      scale_y_log10()+
      # annotation_logticks(sides = "l")+
      theme_bw()+
      theme(panel.grid.minor.x = element_blank())+
      scale_x_date(labels = function(x) format(x, "%b"),date_breaks = "1 months")+
      guides(colour=FALSE)

    ggplotly(ploty, tooltip=c("flow","Date"))


  })
  #fig dimensions
  output$fig_x <- renderText({ input$fig_x })
  output$fig_y <- renderText({ input$fig_y })
  #facet columns
  output$facet_x <- renderText({ input$facet_x })
  #download to computer
  output$downloadImage <- downloadHandler(
    filename = function(){paste("plot",'.png',sep='')},
    content = function(file){
      ggsave(file,width = input$fig_x,height = input$fig_y, dpi = 600, units = "in", device='png')
      print(ggplot(data = df4() ,mapping = aes(x = commonDate, y = flow, colour = factor(WY))) +
              geom_line() +
              #geom_point()+
              #geom_vline(data = trip,aes(xintercept=commonDate),trip_df,color="black")+
              labs(x = " ", y = "Discharge (cfs)") +
              facet_wrap(facets = ~WY,ncol=as.integer(input$facet_x)) +
              scale_y_log10()+
              annotation_logticks(sides = "l")+
              theme_bw()+
              theme(panel.grid.minor.x = element_blank())+
              scale_x_date(labels = function(x) format(x, "%b"),date_breaks = "1 months")+
              guides(colour=FALSE))
    })
}

I should note, I wasn't able to get this to work as `scale_y_log_eng` is not a defined function and plotly didn't want to render the graphs in more than one facet. If you've got it working up to the point of the question you asked, then these fixes should apply to your problem above. — Andy Baxter, Dec 02 '19 at 15:27
This works great but I can't get the `downloadHandler` to respond to the `numericImput`. I tried adding df4() as the data but it doesn't seem to be responding. — Srizza, Dec 02 '19 at 17:44
oops, sorry hadn't noticed the second call of df4, have added the brackets above - `ggplot(data = df4()...` - and that works for me, try the new code. — Andy Baxter, Dec 02 '19 at 21:48
You still need to hit the update figure button for the figure dimensions to be set. Is there a way for them to reactively be updated? — Srizza, Dec 02 '19 at 23:55
Ah I see! Then the way to do that is to change your `submitButton` to an `actionButton` so that it doesn't block all updates, and you can still use it to only control when the data is downloaded. I'll quickly test this out and update the code. see https://shiny.rstudio.com/articles/action-buttons.html for more info. — Andy Baxter, Dec 03 '19 at 00:18
that's a code now which still has a button but which only holds back the process of downloading new data till it's pressed. Updating facets and figure download dimensions works reactively. take out the button and change `eventReactive` back to `reactive` (without call to `input$update` just after) if you want to remove the button entirely. — Andy Baxter, Dec 03 '19 at 00:26
Turns out that `eventReactive` seems to be making none of the downloading or plotting occur. Not sure where the issue is. Can you get it to run? — Srizza, Dec 03 '19 at 04:44
`eventReactive` is set by default to wait for the first press of the button. If you'd prefer it to load some data and a graph on page load, change the line to `df4 <- eventReactive(input$update, ignoreNULL = FALSE, {` - see new edits above. — Andy Baxter, Dec 03 '19 at 09:01
The `actionButton` argument `id` needed to be changed to `inputID`. Could you update that in your answer? Thanks for all your help! — Srizza, Dec 03 '19 at 16:52
Well spotted! Have amended in the answer. Apologies for the oversight, was quickly re-typing rather than copy-pasting the whole ui section. Glad it works now. — Andy Baxter, Dec 03 '19 at 20:45

Shiny app: Download data source outside of renderPlot for quicker user manipulation

1 Answers1