Блестящее приложение: загрузите источник данных за пределами renderPlot для более быстрой манипуляции с пользователем

Question

Это мое первое блестящее приложение. Я бы хотел, чтобы пользователь мог обновлять количество колонок фасетов и размеры загружаемого графика. readNWISuv, функция загрузки данных может занять много времени, если запрашивается несколько лет. В настоящее время приложение загружает данные каждый раз, когда пользователь хочет изменить формат графика или размеры графика. Не уверен, что мне нужно использовать reactiveValues, но я бы предположил, что я хочу, чтобы данные загружались и манипулировали за пределами renderPlot. Благодарность!

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)

Answer 1

Есть несколько изменений, которые необходимо внести в раздел вашего сервера, чтобы сделать эту работу. Прежде всего:

• разбиение создания кадра данных на новую функцию eventReactive, в зависимости от actionButton.
• , ссылающегося на функцию внутри вызова renderPlotly

Попробуйте это:

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