r - 如何设置条件以在 Shiny 的应用程序中显示日期范围

Question

我想在下面的代码中添加另一个条件。请注意，当选择 Excel 选项并在 fileInput 中加载文件时，daterange 会被激活 - 这工作正常。但是，我还想在连接到数据库后(即按下database 选项后)激活daterange。如何在代码中调整它？

library(shiny)
library(dplyr)
library(shinythemes)

ui <- fluidPage(
  
  shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
                    br(),
                    tabPanel("PAGE1",
                             sidebarLayout(
                               sidebarPanel(
                                 radioButtons("button", 
                                              label = h3("Data source"),
                                              choices = list("Excel" = "Excel",
                                                             "Database" = "database"), 
                                              selected = "File"),
                                 
                                 uiOutput('fileInput'),
                                 
                                 conditionalPanel(
                                   condition = "output.fileUploaded == true",
                                   uiOutput("daterange"),
                                 )),
                               mainPanel(
                                 dataTableOutput('table')
                               )))))


server <- function(input, output) {
  

  observe({
    if(is.null(input$button)) {
      
    }else if (input$button =="Excel"){
      
      output$fileInput <- renderUI({
        fileInput("file",h4("Import file"), multiple = T, accept = ".xlsx")
      })
      
      
    } else if(input$button=="database"){
      
      
      con <- DBI::dbConnect(odbc::odbc(),
                            Driver   = "[your driver's name]",
                            Server   = "[your server's path]",
                            Database = "[your database's name]",
                            UID      = rstudioapi::askForPassword("Database user"),
                            PWD      = rstudioapi::askForPassword("Database password"),
                            Port     = 1433)
      
      data <-tbl(con, in_schema("dbo", "date1")) %>%
        collect()
      
    } 
  })
  
  data <- reactive({
    if (is.null(input$file)) {
      return(NULL)
    }
    
    else {
      df3 <- read_excel(input$file$datapath)
      validate(need(all(c('date1', 'date2') %in% colnames(df3)), "Incorrect file"))
      df4 <- df3 %>% mutate_if(~inherits(., what = "POSIXct"), as.Date)
      return(df4)
    }
  })

  
  output$fileUploaded <- reactive({
    return(!is.null(data()))
  })
  outputOptions(output, 'fileUploaded', suspendWhenHidden=FALSE)
  
  
  output$daterange <- renderUI({
    req(data())
    dateRangeInput("daterange1", "Period you want to see:",
                   start = min(data()$date2),
                   end   = max(data()$date2))
  })
  
  data_subset <- reactive({
    req(input$daterange1)
    days <- seq(input$daterange1[1], input$daterange1[2], by = 'day')
    subset(data(), date2 %in% days)
  })
  
  output$table <- renderDataTable({
    data_subset()
  })
  
}

shinyApp(ui = ui, server = server)

Answer 1

您可以将 Excel/database 条件放入 data 响应式(Reactive)中。
出于测试目的，我用测试数据替换了数据库数据:

library(shiny)
library(dplyr)
library(shinythemes)
library(readxl)

ui <- fluidPage(
  
  shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
                    br(),
                    tabPanel("PAGE1",
                             sidebarLayout(
                               sidebarPanel(
                                 radioButtons("button", 
                                              label = h3("Data source"),
                                              choices = list("Excel" = "Excel",
                                                             "Database" = "database"), 
                                              selected = "File"),
                                 
                                 uiOutput('fileInput'),
                                 
                                 conditionalPanel(
                                   condition = "output.fileUploaded == true",
                                   uiOutput("daterange"),
                                 )),
                               mainPanel(
                                 dataTableOutput('table')
                               )))))


Test <- structure(list(date1 = structure(c(18808, 18808, 18809, 18810
), class = "Date"),date2 = structure(c(18808, 18808, 18809, 18810
), class = "Date"), Category = c("FDE", "ABC", "FDE", "ABC"), 
coef = c(4, 1, 6, 1)), row.names = c(NA, 4L), class = "data.frame")

server <- function(input, output) {
  
  
  observe({
   req(input$button)  
   if (input$button =="Excel") {
      output$fileInput <- renderUI({
        fileInput("file",h4("Import file"), multiple = T, accept = ".xlsx")
      })
    }
  })
  
  data <- reactive({
    req(input$button)
    if (input$button=="Excel") {
      if (is.null(input$file)) {
        return(NULL)
      }
      else {
        df3 <- read_excel(input$file$datapath)
        validate(need(all(c('date1', 'date2') %in% colnames(df3)), "Incorrect file"))
        df4 <- df3 %>% mutate_if(~inherits(., what = "POSIXct"), as.Date)
        return(df4)
      }}
    else if (input$button=="database") {
      cat('database')
      # con <- DBI::dbConnect(odbc::odbc(),
      #                       Driver   = "[your driver's name]",
      #                       Server   = "[your server's path]",
      #                       Database = "[your database's name]",
      #                       UID      = rstudioapi::askForPassword("Database user"),
      #                       PWD      = rstudioapi::askForPassword("Database password"),
      #                       Port     = 1433)
      
      #tbl(con, in_schema("dbo", "date1")) %>%  collect()
      # For test
      Test
    }
  })
  
  output$fileUploaded <- reactive({
    req(!is.null(data()))
    return(!is.null(data()))
  })
  outputOptions(output, 'fileUploaded', suspendWhenHidden=FALSE)
  
  
  output$daterange <- renderUI({
    req(!is.null(data()))
    dateRangeInput("daterange1", "Period you want to see:",
                   start = min(data()$date2),
                   end   = max(data()$date2))
  })
  
  data_subset <- reactive({
    req(input$daterange1,!is.null(data()))
    days <- seq(input$daterange1[1], input$daterange1[2], by = 'day')
    subset(data(), date2 %in% days)
  })
  
  output$table <- renderDataTable({
    data_subset()
  })
  
}

shinyApp(ui = ui, server = server)