在 Shiny 中调整日期的输出

Question

以下APP运行正常。但是，我希望与日期相关的输出值有所不同，也就是说，而不是 2021-01-01 出现，我希望它们像这样出现：01-01-2021。显然，无需直接更改df database 并且输出为yes。

非常感谢！

library(shiny)
library(shinythemes)

function.cl<-function(df,date, d1,d2){
  
  df <- structure(
   list(date = c("2021-01-01","2021-01-02","2021-01-03","2021-01-04","2021-01-05"),
         d1 = c(0,1,4,5,6), d2 = c(2,4,5,6,7)),class = "data.frame", row.names = c(NA, -5L))
}    
ui <- fluidPage(
  
  ui <- shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
                          br(),
                          
                          tabPanel("",
                                     sidebarLayout(
                                     sidebarPanel(
                                       
                                       selectInput("date", label = h4("Date"),""),
                                       selectInput("d1", label = h4("D1"),""),
                                       selectInput("d2", label = h4("D2"),""),
                                       br(),
                                       actionButton("reset", "Reset"),
                                     ),
                                     
                                     mainPanel(
                                     ))
                          )))


server <- function(input, output,session) {
  data <- reactive(function.cl())
  
  observe({
    updateSelectInput(session, "date",labe ="Date", unique(data()$date))
    updateSelectInput(session, "d1", label = "D1", unique(data()$d1))
    updateSelectInput(session, "d2", label = "D2", unique(data()$d2))
  })
  

}

shinyApp(ui = ui, server = server)

#新代码

library(shiny)
library(shinythemes)
library(openxlsx)
library(shinyBS)
library(shinyWidgets)
library(openxlsx)
library(writexl)
library(readxl)
library(DT)

ui <- fluidPage(
  
  ui <- shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
                          br(),
                          
                          tabPanel("",
                                   fileInput("file", "Please upload a file", accept = c(".xlsx")),
                                   sidebarLayout(
                                     sidebarPanel(
                                       
                                       selectInput("date", label = h4("Date"),""),
                                       selectInput("d1", label = h4("D1"),""),
                                       selectInput("d2", label = h4("D2"),""),
                                       br(),
                                       
                                     ),
                                     
                                     mainPanel( 
                                     ))
                          )))


server <- function(input, output, session) {
  df1 <- reactiveValues(dat=NULL)
  
  data <- eventReactive(input$file, {
    if (is.null(input$file)) return(NULL)
    df <- read_excel(input$file$datapath)
    df
  })
  
  observe({
    df1$dat <- data()
  })
  
  observeEvent(input$file, {
    
    if (!is.null(df1$dat)) {
      data <- df1$dat
      updateSelectInput(session, "date", label = "Date", unique(data$Date))
      updateSelectInput(session, "d1", label = "D1", unique(data$D1))
      updateSelectInput(session, "d2", label = "D2", unique(data$D2))
    }
    
  })
  
}

shinyApp(ui = ui, server = server)

Answer 1

为什么不使用dateInput() input type 而不是selectInput()？

如果您只希望特定日期符合选择条件，您可以禁用dateInput() 中的其他日期。但是，这变成了slightly more complex，因为您无法使用updateDateInput() 函数更新datesdisabled 参数，我假设您想要美国风格的day-month-year 格式，但如果不是，您可以编辑格式。

例如：

library(shiny)
library(shinythemes)

function.cl<-function(df,date, d1,d2){
    df <- structure(
        list(date = c("2021-01-01","2021-01-02","2021-01-03","2021-01-04","2021-01-05"),
             d1 = c(0,1,4,5,6), d2 = c(2,4,5,6,7)),class = "data.frame", row.names = c(NA, -5L))
}    
ui <- fluidPage(
    
    ui <- shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
                            br(),
                            
                            tabPanel("",
                                     sidebarLayout(
                                         sidebarPanel(
                                             
                                             uiOutput("date"),
                                             selectInput("d1", label = h4("D1"),""),
                                             selectInput("d2", label = h4("D2"),""),
                                             br(),
                                             actionButton("reset", "Reset"),
                                         ),
                                         
                                         mainPanel(
                                         ))
                            )))


server <- function(input, output,session) {
    data <- reactive(function.cl())
      
    output$date <- renderUI({
        all_dates <- seq(as.Date('2021-01-01'), as.Date('2021-01-15'), by = "day")
        disabled <- as.Date(setdiff(all_dates, as.Date(data()$date)), origin = "1970-01-01")
        
        dateInput(input = "date", 
                  label = "Select Date",
                  min = min(data()$date),
                  max = max(data()$date),
                  value = max(data()$date),
                  format = "dd-mm-yyyy",
                  datesdisabled = disabled)
    })

    observe({
        updateSelectInput(session, "d1", label = "D1", unique(data()$d1))
        updateSelectInput(session, "d2", label = "D2", unique(data()$d2))
    })
}

shinyApp(ui = ui, server = server)

编辑：或者，您刚刚将上述日期定义为字符串，因此您可以重新格式化字符串。

即可以更改定义数据的函数：

function.cl<-function(df,date, d1,d2){
    
    df <- structure(
        list(date = c("01-01-2021","01-02-2021","01-03-2021","01-04-2021","01-05-2021"),
             d1 = c(0,1,4,5,6), d2 = c(2,4,5,6,7)),class = "data.frame", row.names = c(NA, -5L))
}

如果你真的想使用selectInput() 函数并且你真的希望日期为Date 类型而不是字符，你也可以在字符串和日期之间来回设置格式。

例如：

library(shiny)
library(shinythemes)

function.cl<-function(df,date, d1,d2){
    
    df <- structure(
        list(date = as.Date(c("01-01-2021","01-02-2021","01-03-2021","01-03-2021","01-05-2021"), format = "%m-%d-%Y"),
             d1 = c(0,1,4,5,6), d2 = c(2,4,5,6,7)),class = "data.frame", row.names = c(NA, -5L))
}    
ui <- fluidPage(
    
    ui <- shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
                            br(),
                            
                            tabPanel("",
                                     sidebarLayout(
                                         sidebarPanel(
                                             
                                             selectInput("date", label = h4("Date"),""),
                                             selectInput("d1", label = h4("D1"),""),
                                             selectInput("d2", label = h4("D2"),""),
                                             br(),
                                             actionButton("reset", "Reset"),
                                         ),
                                         
                                         mainPanel(
                                         ))
                            )))


server <- function(input, output,session) {
    data <- reactive(function.cl())
    
    observe({
        updateSelectInput(session, "date",labe ="Date", unique(format(data()$date, format = "%m-%d-%Y")))
        updateSelectInput(session, "d1", label = "D1", unique(data()$d1))
        updateSelectInput(session, "d2", label = "D2", unique(data()$d2))
    })    
}

shinyApp(ui = ui, server = server)