R Shiny 如何为 Dataframe 创建依赖过滤器

Question

我需要创建一个应用程序来过滤数据框中的多个字段。当第一个字段被过滤（使用日期范围）时，用户必须在数据显示在表中之前过滤几个 pickerInputs。我不确定这是否是创建依赖过滤器的最佳方式。我似乎找不到足够的资源。我尝试了以下方法。但是，我不确定为什么我不断收到此警告::

警告：错误：filter() 输入“..1”有问题 X 输入“..1”的大小必须为 100 或 1，而不是 0

get_data <- function(size){
  longs <- seq(from=40, to =90, by = 0.01)
  lats <- seq(from = 5, to= 50, by = 0.01)
  LONGITUDE <- sample(longs, size, rep = TRUE)
  LATITUDE <- sample(lats, size, rep = TRUE)
  df <- data.frame(cbind(LONGITUDE, LATITUDE))
  df$LOCATION <- sample(c("Location_A", "Location_B", "Location_C"), size, replace = T, prob = c(0.4, 0.4, 0.2))
  df$EQUIPMENT <- sample(c("Equipment_A", "Equipment_B", "Equipment_C", "Equipment_D"), size, replace = TRUE)
  startTime <- as.POSIXct("2016-01-01")
  endTime <- as.POSIXct("2019-01-31")
  df$DATE <- as.Date(sample(seq(startTime, endTime, 1), size))
  df$WEEKDAY <- weekdays(as.Date(df$DATE))
  
  return(df)
}

df <-get_data(100)

ui <- navbarPage(
  id = "navBar",
  title = "Data Exploration",
  theme = shinytheme("cerulean"), 
  shinyjs::useShinyjs(),
  selected = "Data",
  
  
  tabPanel("Data",
           fluidPage(
             sidebarPanel(
               
               
               div(id = "form",
                   uiOutput('timestamp'),
                   uiOutput('location'),
                   uiOutput('days_of_week'),
                   uiOutput('equipment_type'),
                   hr(),
                   HTML("<h3>Reset your filter settings here:</h3>"),
                   actionButton("resetAll", "Reset Entries"),
                   hr()),
               mainPanel(
                 DT::DTOutput("datatable"))))
  )
  
)#end the ui


server <- function(session, input, output){
  filter_data <- reactive({
    df %>%
      filter(DATE >= input$timestamp[1] & DATE <= input$timestamp[2]) %>%
      filter(LOCATION %in% input$location) %>%
      filter(WEEKDAY %in% input$days_of_week) %>%
      filter(EQUIPMENT %in% input$equipment_type)
  })
  
  output$timestamp <- renderUI({
    dateRangeInput('timestamp',label = 'Date range input:',start = min(df$DATE), end = max(df$DATE))
  })
  
  output$location <- renderUI({
    location <- reactive({
      df %>%
        filter(DATE >= input$timestamp[1] & DATE <= input$timestamp[2]) %>%
        pull(LOCATION) %>%
        as.character() %>% unique()
      
    })
    pickerInput('location', "Select Location:", choices = location(),selected = NULL, options = list(`actions-box` = TRUE),multiple = T)
  })
  
  output$days_of_week <- renderUI({
    days_of_week <- reactive({
      df %>%
        filter(DATE >= input$timestamp[1] & DATE <= input$timestamp[2]) %>%
        filter(LOCATION %in% input$location) %>%
        pull(WEEKDAY) %>%
        as.character() %>% unique()
      
    })
    pickerInput('days_of_week', 'Choose Weekdays:', choices=days_of_week(), selected = NULL, options = list(`actions-box` = TRUE),multiple = T)
  })
  
  output$equipment_type <- renderUI({
    equipment <- reactive({
      df %>%
        filter(DATE >= input$timestamp[1] & DATE <= input$timestamp[2]) %>%
        filter(LOCATION%in% input$location) %>%
        filter(WEEKDAY %in% input$days_of_week) %>%
        pull(EQUIPMENT) %>%
        as.character() %>% unique()
    })
    pickerInput('equipment_type', "Choose Equipment:", choices = equipment(),selected = NULL, options = list(`actions-box` = TRUE),multiple = T)
  })
  
  output$datatable <- DT::renderDT({
    filter_data()
  })
  
  #Allow the user to reset all their inputs
  observeEvent(input$resetAll, {
    reset("form")
  })
  
}

shinyApp(ui, server)

Answer 1

我认为您的警告是由于在您创建 dateRangeInput 之前，input$timestamp 第一次在您的反应式表达式中为 NULL。

您可以将input 移动到ui，然后在日期更改时使用updatePickerInput 以相应地更改您的其他输入。

您可能希望包含两个单独的reaction 表达式。一种用于根据日期范围过滤数据，用于更新其他选择器。第二个将包括基于选择器选择的位置、设备和工作日的其他过滤器。

看看这是否提供了更接近您正在寻找的东西。我在顶部包括了似乎是相关的软件包。我还稍微调整了ui 中的括号。

library(shinythemes)
library(shinyWidgets)
library(shinyjs)
library(shiny)
library(dplyr)

get_data <- function(size){
  longs <- seq(from=40, to =90, by = 0.01)
  lats <- seq(from = 5, to= 50, by = 0.01)
  LONGITUDE <- sample(longs, size, rep = TRUE)
  LATITUDE <- sample(lats, size, rep = TRUE)
  df <- data.frame(cbind(LONGITUDE, LATITUDE))
  df$LOCATION <- sample(c("Location_A", "Location_B", "Location_C"), size, replace = T, prob = c(0.4, 0.4, 0.2))
  df$EQUIPMENT <- sample(c("Equipment_A", "Equipment_B", "Equipment_C", "Equipment_D"), size, replace = TRUE)
  startTime <- as.POSIXct("2016-01-01")
  endTime <- as.POSIXct("2019-01-31")
  df$DATE <- as.Date(sample(seq(startTime, endTime, 1), size))
  df$WEEKDAY <- weekdays(as.Date(df$DATE))
  
  return(df)
}

df <-get_data(100)

ui <- navbarPage(
  id = "navBar",
  title = "Data Exploration",
  theme = shinytheme("cerulean"), 
  shinyjs::useShinyjs(),
  selected = "Data",
  
  tabPanel("Data",
           fluidPage(
             sidebarPanel(
               div(id = "form",
                   dateRangeInput('timestamp', label = 'Date range input:', start = min(df$DATE), end = max(df$DATE)),
                   pickerInput('location', "Select Location:", choices = unique(df$LOCATION), options = list(`actions-box` = TRUE), multiple = T),
                   pickerInput('days_of_week', 'Choose Weekdays:', choices = unique(df$WEEKDAY), options = list(`actions-box` = TRUE), multiple = T),
                   pickerInput('equipment_type', "Choose Equipment:", choices = unique(df$EQUIPMENT), options = list(`actions-box` = TRUE), multiple = T),
                   hr(),
                   HTML("<h3>Reset your filter settings here:</h3>"),
                   actionButton("resetAll", "Reset Entries"),
                   hr())
               ),
               mainPanel(
                 DT::DTOutput("datatable")))
  )
)#end the ui

server <- function(session, input, output){
  
  filter_by_dates <- reactive({
    filter(df, DATE >= input$timestamp[1] & DATE <= input$timestamp[2])
  })
  
  filter_by_all <- reactive({
    fd <- filter_by_dates()
    
    if (!is.null(input$location)) {
      fd <- filter(fd, LOCATION %in% input$location)
    }
    
    if (!is.null(input$days_of_week)) {
      fd <- filter(fd, WEEKDAY %in% input$days_of_week)
    }
    
    if (!is.null(input$equipment_type)) {
      fd <- filter(fd, EQUIPMENT %in% input$equipment_type)
    }         
             
    return(fd)
  })
  
  observeEvent(input$timestamp, {
    updatePickerInput(session, 'location', "Select Location:", choices = unique(filter_by_dates()$LOCATION), selected = input$location)
    updatePickerInput(session, 'days_of_week', 'Choose Weekdays:', choices = unique(filter_by_dates()$WEEKDAY), selected = input$days_of_week)
    updatePickerInput(session, 'equipment_type', "Choose Equipment:", choices = unique(filter_by_dates()$EQUIPMENT), selected = input$equipment_type)
  })
  
  output$datatable <- DT::renderDT({
    filter_by_all()
  })
  
  #Allow the user to reset all their inputs
  observeEvent(input$resetAll, {
    reset("form")
  })
  
}

shinyApp(ui, server)

编辑（21 年 1 月 28 日）：根据评论，似乎有兴趣根据所做的选择更新所有输入选择。

如果您将observeEvent 替换为observe，并在三个updatePickerInput 中使用filter_by_all() 而不是filter_by_date()，那么只要对任何输入进行任何更改，所有非日期输入选项都会更新：

  observe({
    input$timestamp
    updatePickerInput(session, 'location', "Select Location:", choices = unique(filter_by_all()$LOCATION), selected = input$location)
    updatePickerInput(session, 'days_of_week', 'Choose Weekdays:', choices = unique(filter_by_all()$WEEKDAY), selected = input$days_of_week)
    updatePickerInput(session, 'equipment_type', "Choose Equipment:", choices = unique(filter_by_all()$EQUIPMENT), selected = input$equipment_type)
  })