在闪亮模块中，如何根据先前过滤器中的选择动态更新多个过滤器？

Question

我们目前正在实施 Shiny 模块来管理我们的 Shiny 应用程序中的多个过滤器。用户可以选择特定的校园、专业或部门，后续过滤器应相应调整。但是，我们遇到了一个问题，即当用户选择另一个校园时，专业服务器中的观察者不会更新。我提供了示例数据和我们的代码以供参考。我将非常感谢任何有关我们可能犯错误的地方的见解。

library(tidyverse)
library(shiny)
library(shinyWidgets)
library(shinydashboard)

data <- data.frame(
  CAMPUS = c("Campus A", "Campus A", "Campus B", "Campus B", "Campus C"),
  SPECIALTY = c("Cardiology", "Neurology", "Cardiology", "Orthopedics", "Oncology"),
  DEPARTMENT = c("Cardiology Department", "Neurology Department", "Cardiology Department", "Orthopedics Department", "Oncology Department")
)


# Define UI for Campus
CampusInput <- function(id, data) {
  
  campus_choices <- data %>% 
    select(CAMPUS) %>% distinct() %>% pull()
  
  box(
    title = "Select Campus:",
    width = 12,
    height = "100px",
    solidHeader = FALSE,
    pickerInput(NS(id, "selectedCampus"),
                label=NULL,
                choices=  campus_choices,
                multiple=TRUE,
                selected = campus_choices[1]))
}



# Define Server for Campus
CampusServer <- function(id) {
  moduleServer(id, function(input, output, session) {
    reactive({
      input$selectedCampus
    })
  })
}


# Define UI for Specialty
SpecialtyInput <- function(id) {
  
  box(
    title = "Select Specialty:",
    width = 12,
    height = "100px",
    solidHeader = FALSE,
    pickerInput(NS(id,"selectedSpecialty"),
                label=NULL,
                choices= NULL,
                multiple=TRUE,
                selected = NULL))
}


# Define Server for Specialty
SpecialtyServer <- function(id, data, campus) {
  moduleServer(id, function(input, output, session) {
    observeEvent(campus, {
      if(!is.null(campus)) {
        
        print(campus)
        specailty_choices <-  data %>% filter(CAMPUS %in% campus) %>%
          select(SPECIALTY) %>% distinct() %>% pull()
        
        updatePickerInput(session,
                          inputId = id,
                          choices = specailty_choices,
                          selected = specailty_choices)
      }
    })
    
  })
  
}



# Define UI for Department
DepartmentInput <- function(id) {
  box(
    title = "Select Department:",
    width = 12,
    height = "100px",
    solidHeader = FALSE,
    pickerInput(NS(id,"selectedDepartment"),
                label=NULL,
                choices= NULL,
                multiple=TRUE,
                selected = NULL))
}


# Define Server for Department
DepartmentServer <- function(id, data, campus, specialty) {
  moduleServer(id, function(input, output, session) {
    observeEvent(specialty, {
      if(!is.null(specialty)) {
        
        department_choices <-  data %>% filter(CAMPUS %in% campus, CAMPUS_SPECIALTY %in% specialty ) %>%
          select(DEPARTMENT) %>% distinct() %>% pull()
        
        updatePickerInput(session,
                          inputId = id,
                          choices = department_choices,
                          selected = department_choices)
      }
    })
  })
  
}


#Define UI for the app
ui <- fluidPage(
  CampusInput("selectedCampus", data = data),
  SpecialtyInput("selectedSpecialty"),
  DepartmentInput("selectedDepartment"),
  textOutput("result")
  
)

#Define Server for the app
server <- function(input, output, session) {
  selected_campus <- CampusServer("selectedCampus")
  selected_specialty <- SpecialtyServer("selectedSpecialty", data = data, campus = selected_campus())
  selected_department <- DepartmentServer("selectedDepartment", data = data, 
                                          campus = selected_campus(), specialty = selected_specialty())
  
  output$result <- renderText(selected_department())
}

shinyApp(ui, server)

我们阅读了第19章闪亮模块和stackoverflow和stackoverflow1。尽管我们付出了努力，但我们还没有找到解决我们具体案例的示例。

Answer 1

将反应函数传递给模块时，请以

selected_campus

形式发送函数，末尾不带

()

。然后在模块内使用 Campus()。这是工作代码。

library(tidyverse)
library(shiny)
library(shinyWidgets)
library(shinydashboard)

data <- data.frame(
  CAMPUS = c("Campus A", "Campus A", "Campus B", "Campus B", "Campus C"),
  SPECIALTY = c("Cardiology", "Neurology", "Cardiology", "Orthopedics", "Oncology"),
  DEPARTMENT = c("Cardiology Department", "Neurology Department", "Cardiology Department", "Orthopedics Department", "Oncology Department")
)

campus_choices <- data %>% 
  select(CAMPUS) %>% distinct() %>% pull()

# Define UI for Campus
CampusInput <- function(id, data) {
  box(
    title = "Select Campus:",
    width = 12,
    height = "100px",
    solidHeader = FALSE,
    pickerInput(NS(id, "selectedCampus"),
                label=NULL,
                choices=  campus_choices,
                multiple=TRUE,
                selected = campus_choices[1]))
}



# Define Server for Campus
CampusServer <- function(id) {
  moduleServer(id, function(input, output, session) {
    reactive({
      input$selectedCampus
    })
  })
}


# Define UI for Specialty
SpecialtyInput <- function(id) {
  
  box(
    title = "Select Specialty:",
    width = 12,
    height = "100px",
    solidHeader = FALSE,
    pickerInput(NS(id,"selectedSpecialty"),
                label=NULL,
                choices= NULL,
                multiple=TRUE,
                selected = NULL))
}


# Define Server for Specialty
SpecialtyServer <- function(id, data, campus) {
  moduleServer(id, function(input, output, session) {
    observeEvent(campus(), {
      if(!is.null(campus())) {
        
        print(campus())
        specailty_choices <-  data %>% dplyr::filter(CAMPUS %in% campus()) %>%
          select(SPECIALTY) %>% distinct() %>% pull()
        
        updatePickerInput(session,
                          inputId = id,
                          choices = specailty_choices,
                          selected = specailty_choices)
      }
    }, ignoreNULL = FALSE)
    
    return(reactive(input[[paste0("selectedSpecialty")]]))
    
  })
  
}



# Define UI for Department
DepartmentInput <- function(id) {
  box(
    title = "Select Department:",
    width = 12,
    height = "100px",
    solidHeader = FALSE,
    pickerInput(NS(id,"selectedDepartment"),
                label=NULL,
                choices= NULL,
                multiple=TRUE,
                selected = NULL))
}


# Define Server for Department
DepartmentServer <- function(id, data, campus, specialty) {
  moduleServer(id, function(input, output, session) {
    observeEvent(specialty(), {
      # print(specialty())
      if(!is.null(specialty())) {
        
        department_choices <-  data %>% dplyr::filter(CAMPUS %in% campus(), SPECIALTY %in% specialty() ) %>%
          select(DEPARTMENT) %>% distinct() %>% pull()
        # print(department_choices)
        updatePickerInput(session,
                          inputId = id,
                          choices = department_choices,
                          selected = department_choices)
      }
    }, ignoreNULL = FALSE)
    # observe({print(input$selectedDepartment )})
    return(reactive(input[["selectedDepartment"]]))
  })
  
}


#Define UI for the app
ui <- fluidPage(
  CampusInput("selectedCampus", data = data),
  SpecialtyInput("selectedSpecialty"),
  DepartmentInput("selectedDepartment"),
  textOutput("result")
  
)

#Define Server for the app
server <- function(input, output, session) {
  selected_campus <- CampusServer("selectedCampus")
  
  selected_specialty <- SpecialtyServer("selectedSpecialty", data = data, campus = selected_campus )
  
  selected_department <- DepartmentServer("selectedDepartment", data = data,
                                          campus = selected_campus, specialty = selected_specialty )

  output$result <- renderText(selected_department())
}

shinyApp(ui, server)