能够 select 闪亮输入中的所有潜在选项以及动态 table

Question

下面的代码允许三个不同的“阶段”选择，每个输入都依赖于之前的输入。现在的代码是这样的：

  ui <- fluidPage(
  titlePanel("Test Dashboard "),
  sidebarLayout(
    sidebarPanel(
      uiOutput("data1"),   ## uiOutput - gets the UI from the server
      uiOutput("data2"),
      uiOutput("data3")
    ),
    mainPanel()
  ))


server <- function(input, output){
  
  State <- c("NV", "NV","NV", "MD", "MD", "MD", "MD", "NY", "NY", "NY", "OH", "OH", "OH")
  County <- c("CLARK", "WASHOE", "EUREKA", "MONTGOMERY", "HOWARD", "BALTIMORE", "FREDERICK", "BRONX", "QUEENS", "WESTCHESTER", "FRANKLIN", "SUMMIT", "STARK" )
  City <- c("Las Vegas", "Reno", "Eureka", "Rockville", "Columbia", "Baltimore", "Thurmont", "Bronx", "Queens", "Yonkers", "Columbus", "Akron", "Canton")
  Rating<- c(1,2,3,4,5,6,7,8,9,10,11,12,13)
  df <- data.frame(State, County, City, Rating, stringsAsFactors = F)
  
  ## renderUI - renders a UI element on the server
  ## used when the UI element is dynamic/dependant on data
  output$data1 <- renderUI({
    selectInput("data1", "Select State", choices = c(df$State))
  })
  
  ## input dependant on the choices in `data1`
  output$data2 <- renderUI({
    selectInput("data2", "Select County", choices = c(df$County[df$State == input$data1]))
  })
  
  output$data3 <- renderUI({
    selectInput("data3", "select City", choices = c(df$City[df$County == input$data2]))
  })
  
  
}

shinyApp(ui, server)

您会注意到示例数据在 server 端代码中找到并绑定在一起形成 df。

但是如果我不想缩小每次选择的范围怎么办？相反，假设我想遵循以下选择路径：State = "MD"、County = ALL 和 City = ALL。虽然我可以选择一个或多个选项，但它也会包括选择全部的选项。

此外，我还想包括一个可见的动态 table，它会根据所选值自行调整。因此，如果我按照上面列出的相同选择路径，它将 return 所有在 State = "MD" 下提交的任何内容的附属结果。

每当我尝试添加类似

的内容时

DTOutput('table')

在 UI 端，以下在服务器端：

output$table <- renderDT(df,
                         options = list(
                           pageLength = 5
                         )
)

它只会打乱整个布局，也不会产生我需要的 table。

Answer 1

这里有一些值得尝试的东西。您可以使用 updateSelectInput 更改您的输入并使它们依赖。单独的 reactive 表达式可以根据您的输入过滤数据。看看这是否为您提供了预期的行为。

library(shiny)
library(DT)

State <- c("NV", "NV","NV", "MD", "MD", "MD", "MD", "NY", "NY", "NY", "OH", "OH", "OH")
County <- c("CLARK", "WASHOE", "EUREKA", "MONTGOMERY", "HOWARD", "BALTIMORE", "FREDERICK", "BRONX", "QUEENS", "WESTCHESTER", "FRANKLIN", "SUMMIT", "STARK" )
City <- c("Las Vegas", "Reno", "Eureka", "Rockville", "Columbia", "Baltimore", "Thurmont", "Bronx", "Queens", "Yonkers", "Columbus", "Akron", "Canton")
Rating<- c(1,2,3,4,5,6,7,8,9,10,11,12,13)
df <- data.frame(State, County, City, Rating, stringsAsFactors = F)

ui <- fluidPage(
  titlePanel("Test Dashboard "),
  sidebarLayout(
    sidebarPanel(
      selectInput("data1", "Select State", choices = c("All", unique(df$State))),
      selectInput("data2", "Select County", choices = NULL),
      selectInput("data3", "select City", choices = NULL)
    ),
    mainPanel(
      DTOutput("table")
    )
  ))

server <- function(input, output, session){
  
  observeEvent(input$data1, {
    if (input$data1 != "All") {
      updateSelectInput(session, "data2", "Select County", choices = c("All", unique(df$County[df$State == input$data1])))
    } else {
      updateSelectInput(session, "data2", "Select County", choices = c("All", unique(df$County)))
    }
  }, priority = 2)
  
  observeEvent(c(input$data1, input$data2), {
    if (input$data2 != "All") {
      updateSelectInput(session, "data3", "Select City", choices = c("All", unique(df$City[df$County == input$data2])))
    } else {
      if (input$data1 != "All") {
        updateSelectInput(session, "data3", "Select City", choices = c("All", unique(df$City[df$State == input$data1])))
      } else {
        updateSelectInput(session, "data3", "Select City", choices = c("All", unique(df$City)))
      }
    }
  }, priority = 1)
  
  filtered_data <- reactive({
    temp_data <- df
    if (input$data1 != "All") {
      temp_data <- temp_data[temp_data$State == input$data1, ]
    }
    if (input$data2 != "All") {
      temp_data <- temp_data[temp_data$County == input$data2, ]
    }
    if (input$data3 != "All") {
      temp_data <- temp_data[temp_data$City == input$data3, ]
    }
    temp_data
  })
  
  output$table <- renderDT(
    filtered_data()
  )
  
}

shinyApp(ui, server)

Answer 2

（也在 reddit 上回答过）

这可以通过使用 shinyWidgets 包中的 pickerInput() 来实现

library(shinyWidgets)

output$data2 <- renderUI({
    pickerInput("data2", "Select County", 
                choices = c(df$County[df$State == input$data1]),
                options = list(`actions-box` = TRUE), multiple = T)
  })

这可以实现将您的数据框保存在反应式中并根据用户选择的选项进行过滤

data <- reactive({
    req(input$data1, input$data2, input$data3)
    df <- df %>%
      filter(State == input$data1) %>%
      filter(County %in% input$data2) %>% 
      filter(City %in% input$data3)
    df
  })

洞应用程序将如下所示：

library(shiny)
library(shinyWidgets)
library(DT)

ui <- fluidPage(
  titlePanel("Test Dashboard "),
  sidebarLayout(
    sidebarPanel(
      uiOutput("data1"),   ## uiOutput - gets the UI from the server
      uiOutput("data2"),
      uiOutput("data3")
    ),
    mainPanel(
      DTOutput('table')
    )
  ))


server <- function(input, output, session){
  
  State <- c("NV", "NV","NV", "MD", "MD", "MD", "MD", "NY", "NY", "NY", "OH", "OH", "OH")
  County <- c("CLARK", "WASHOE", "EUREKA", "MONTGOMERY", "HOWARD", "BALTIMORE", "FREDERICK", "BRONX", "QUEENS", "WESTCHESTER", "FRANKLIN", "SUMMIT", "STARK" )
  City <- c("Las Vegas", "Reno", "Eureka", "Rockville", "Columbia", "Baltimore", "Thurmont", "Bronx", "Queens", "Yonkers", "Columbus", "Akron", "Canton")
  Rating<- c(1,2,3,4,5,6,7,8,9,10,11,12,13)
  df <- data.frame(State, County, City, Rating, stringsAsFactors = F)
  
  ## renderUI - renders a UI element on the server
  ## used when the UI element is dynamic/dependant on data
  output$data1 <- renderUI({
    selectInput("data1", "Select State", choices = c(df$State))
  })
  
  ## input dependant on the choices in `data1`
  output$data2 <- renderUI({
    pickerInput("data2", "Select County", 
                choices = c(df$County[df$State == input$data1]),
                options = list(`actions-box` = TRUE), multiple = T)
  })
  
  output$data3 <- renderUI({
    pickerInput("data3", "select City", 
                choices = c(df$City[df$County %in% input$data2]),
                options = list(`actions-box` = TRUE), multiple = T)
  })
  
  data <- reactive({
    req(input$data1, input$data2, input$data3)
    df <- df %>%
      filter(State == input$data1) %>%
      filter(County %in% input$data2) %>% 
      filter(City %in% input$data3)
    df
  })
  
  output$table <- renderDT(
    data(), options = list(pageLength = 5)
  )
  
}

shinyApp(ui, server)

能够 select 闪亮输入中的所有潜在选项以及动态 table

The ability to select ALL potential options in a Shiny input along with a dynamic table

r

shiny

shiny-server

shinydashboard

shinyapps