如何在 r Shiny 中使用 daterangeinput 按名称按月份和年份进行过滤？

Question

我有一份人员名单以及他们每个月从事的项目数量。我希望我闪亮应用的用户选择日期范围输入显示的月份。

library(dplyr)
    testdata <- tibble(employee = c("Justin", "Corey","Sibley"),
                       apr_2021 = c(10, 100, 101),
                       may_2021 = c(1, 4, 7),
                       jun_2021 = c(4, 5, 6),
                       jul_2021 = c(11, 11, 45),
                       aug_2021 = c(4, 5, 7),
                       sep_2021 = c(2, 1, 0),
                       oct_2021 = c(4, 5, 8),
                       nov_2021 = c(4, 1, 1))

我将 daterangeinput() 配置为 M-YYYY 或 Oct_2021 的格式。当我尝试调整 date_filter 输入时，我收到该列不存在的错误（例如，当用户输入 2021 年 8 月 3 日时：

Warning: Error in : Can't subset columns that don't exist.
x Column `2021_03` doesn't exist.

有两种解决方案之一。理想情况下，我想知道为什么 R 会更改我在 daterangeinput 中指定的格式以及如何修复它，这样我就可以保留我当前的代码（如下）。我不确定这是否与我使用 today() 函数有关，但我需要 R 来了解当前月份和年份。

如果不可能的话，第二个解决方案是如何将这些字符串转换为 R 尝试使用的新格式（似乎是 YYYY-mm-dd）。

这是一个可重现的例子：

library(shiny)
library(shinyjs)
library(shinydashboard)
library(shinyWidgets) 
library(dplyr)
library(htmltools)
library(lubridate)
library(stringr)


ui = fluidPage(
    tabsetPanel(
        tabPanel("View 1", fluid = TRUE,
                 sidebarLayout(
                     sidebarPanel(
                         h4("Select Your Desired Filters"),
                         div(id = "inputs",
                             dateRangeInput(
                                 inputId = "date_filter",
                                 label = "Filter by Month and Year",
                                 start = today(),
                                 end = (today() + 90),
                                 min = "Apr-2021",
                                 max = NULL,
                                 format = "M-yyyy",
                                 startview = "month",
                                 weekstart = 0,
                                 language = "en",
                                 separator = " to ",
                                 width = NULL,
                                 autoclose = TRUE
                             ),
                             br()),
                     ),
                     mainPanel(
                         DT::dataTableOutput("mytable")
                         
                     )
                 )
        )
    )
)
server = function(input, output, session) {
    
    #Here's the dataset
    testdata <- tibble(employee = c("Justin", "Corey","Sibley"),
                       apr_2021 = c(10, 100, 101),
                       may_2021 = c(1, 4, 7),
                       jun_2021 = c(4, 5, 6),
                       jul_2021 = c(11, 11, 45),
                       aug_2021 = c(4, 5, 7),
                       sep_2021 = c(2, 1, 0),
                       oct_2021 = c(4, 5, 8),
                       nov_2021 = c(4, 1, 1))
    
    select_values <- reactive({

        from_date <- as.character(input$date_filter[1])
        
        from_date <- tolower(str_replace_all(from_date, "-..-", "_"))
        
        
        to_date <- as.character(input$date_filter[2])
        
        to_date <- tolower(str_replace_all(to_date, "-..-", "_"))
        
        testdata %>%
            dplyr::select(employee, from_date:to_date)
    })

    
    output$mytable = DT::renderDataTable({
        datatable(select_values())
    })
    
    

    
}
shinyApp(ui = ui, server = server)

Answer 1

可能不是最严格的代码，但我让它工作了。

我最初没有将每个日期视为一个字符串，而是将它们制作成一个简单的 1x1 tibble，因此我可以使用 case_when()、separate()，然后以正确的顺序 unite() 字符串。

library(shiny)
library(shinyjs)
library(shinydashboard)
library(shinyWidgets) 
library(dplyr)
library(htmltools)
library(lubridate)
library(stringr)


ui = fluidPage(
    tabsetPanel(
        tabPanel("View 1", fluid = TRUE,
                 sidebarLayout(
                     sidebarPanel(
                         h4("Select Your Desired Filters"),
                         div(id = "inputs",
                             dateRangeInput(
                                 inputId = "date_filter",
                                 label = "Filter by Month and Year",
                                 start = today(),
                                 end = (today() + 90),
                                 min = "Apr-2021",
                                 max = NULL,
                                 format = "M-yyyy",
                                 startview = "month",
                                 weekstart = 0,
                                 language = "en",
                                 separator = " to ",
                                 width = NULL,
                                 autoclose = TRUE
                             ),
                             br()),
                     ),
                     mainPanel(
                         DT::dataTableOutput("mytable")
                         
                     )
                 )
        )
    )
)
server = function(input, output, session) {
    
    #Here's the dataset
    testdata <- tibble(employee = c("Justin", "Corey","Sibley"),
                       apr_2021 = c(10, 100, 101),
                       may_2021 = c(1, 4, 7),
                       jun_2021 = c(4, 5, 6),
                       jul_2021 = c(11, 11, 45),
                       aug_2021 = c(4, 5, 7),
                       sep_2021 = c(2, 1, 0),
                       oct_2021 = c(4, 5, 8),
                       nov_2021 = c(4, 1, 1))
    
    select_values <- reactive({

        from_date <- tibble(date = as.character(input$date_filter[1]))
        
        
        from_date <- from_date %>%
            mutate(date = str_remove_all(date, "-..$")) %>%
            separate(date, into = c("year", "month"), sep = "-") %>%
            mutate(month = case_when(
                month == "01" ~ "jan",
                month == "02" ~ "feb",
                month == "03" ~ "mar",
                month == "04" ~ "apr",
                month == "05" ~ "may",
                month == "06" ~ "jun",
                month == "07" ~ "jul",
                month == "08" ~ "aug",
                month == "09" ~ "sep",
                month == "10" ~ "oct",
                month == "11" ~ "nov",
                month == "12" ~ "dec",
                TRUE~ "ERROR"
            )) %>%
            unite("month_year", c(month, year), sep = "_")
        
        from_date <- parse_character(from_date$month_year)
        
        
        
        to_date <- tibble(date = as.character(input$date_filter[2]))
        
        to_date <- to_date %>%
            mutate(date = str_remove_all(date, "-..$")) %>%
            separate(date, into = c("year", "month"), sep = "-") %>%
            mutate(month = case_when(
                month == "01" ~ "jan",
                month == "02" ~ "feb",
                month == "03" ~ "mar",
                month == "04" ~ "apr",
                month == "05" ~ "may",
                month == "06" ~ "jun",
                month == "07" ~ "jul",
                month == "08" ~ "aug",
                month == "09" ~ "sep",
                month == "10" ~ "oct",
                month == "11" ~ "nov",
                month == "12" ~ "dec",
                TRUE~ "ERROR"
            )) %>%
            unite("month_year", c(month, year), sep = "_")  
        
        to_date <- parse_character(to_date$month_year)
        
        testdata %>%
            dplyr::select(employee, from_date:to_date)
    })

    
    output$mytable = DT::renderDataTable({
        datatable(select_values())
    })
    
    

    
}
shinyApp(ui = ui, server = server)