在多个页面上使用相同的过滤器

Question

我正在创建一个仪表板，在其中将使用带有和不带有过滤器的不同页面。对于其中一个页面，我想在所有子页面上同步过滤器。我用一个模块尝试过此操作，但是如果我在子页面之间切换，则会重置相同过滤器1和相同过滤器2。

这是我正在尝试的示例：

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


# MODULE
# ---------------------

# Function for module UI
filterPanelUI <- function(id) {
  ns <- NS(id)

  fluidRow(
    column(width = 3, 
           # these filters need to be in sync on the different subpages
           uiOutput(ns('select_gender')),
           uiOutput(ns('select_age')),
           actionButton(ns("resetInput"), "RESET")),
    column(width = 9,
           # this part would need to be different for each subpage
           # e.g. different graphs, based on age and gender.
           textOutput(ns('egText2')))
  )
}

# Function for module server logic
filterPanel <- function(input, output, session) {

  # create filters
  ## Dynamic selectInput dropdown, with segments
  output$select_gender <- renderUI({
    input$resetInput
    pickerInput(
      inputId = "gender_choice",
      label = "Gender",
      choices = c('F', 'M'),
      selected =  'F',
      options = list(`actions-box` = TRUE,`selected-text-format` = "count > 3"),
      multiple = TRUE
    )
  })

  ## Dynamic selectInput dropdown, BSR leefstijlsegmentatie
  output$select_age <- renderUI({
    input$resetInput
    pickerInput(
      inputId = "age_choice",
      label = "Age",
      choices = c('0-20', '20-50', '50-80', '80+'),
      selected =  '0-20',
      options = list(`actions-box` = TRUE, `selected-text-format` = "count > 3"),
      multiple = TRUE
    )
  })

  output$egText2 <- renderText({'some content, where filters need to remain identical for subpages of Same'})

}

# UI & SERVER
# ---------------------

ui <- dashboardPage(
  dashboardHeader(), 
  dashboardSidebar(
    sidebarMenu(
      id = "tabs",
      menuItem("Different", tabName = "different"),
      menuItem("Same",
               menuSubItem("Identical-filter 1", tabName = "same1"),
               menuSubItem("Identical-filter 2", tabName = "same2")))),
  dashboardBody(
    tabItems(tabItem("different", textOutput('egText')),
             tabItem("same1", filterPanelUI(id = "id_1")),
             tabItem("same2", filterPanelUI(id = "id_2"))
             )
    )
)

server <- function(input, output, session) {

  output$egText <- renderText({'some content, which is very different than other 2 pages'})

  callModule(module = filterPanel, id = "id_1")
  callModule(module = filterPanel, id = "id_2")

}

shinyApp(ui, server)

有人知道我该怎么做吗？

谢谢！

Answer 1

首先，您应该在模块内部提供另一个参数，否则多个输入将共享相同的ID，这将导致错误。

您可以使用observeEvent进行呼叫以检查是否单击了选项卡，并根据另一个选项卡的值更新pickerInput。

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


# MODULE
# ---------------------

# Function for module UI
filterPanelUI <- function(id) {
    ns <- NS(id)

    fluidRow(
        column(width = 3, 
               # these filters need to be in sync on the different subpages
               uiOutput(ns('select_gender')),
               uiOutput(ns('select_age')),
               actionButton(ns("resetInput"), "RESET")),
        column(width = 9,
               # this part would need to be different for each subpage
               # e.g. different graphs, based on age and gender.
               textOutput(ns('egText2')))
    )
}

# Function for module server logic
filterPanel <- function(input, output, session, x) {

    # create filters
    ## Dynamic selectInput dropdown, with segments
    output$select_gender <- renderUI({
        input$resetInput
        pickerInput(
            inputId = paste0(x, "gender_choice"),
            label = "Gender",
            choices = c('F', 'M'),
            selected =  'F',
            options = list(`actions-box` = TRUE,`selected-text-format` = "count > 3"),
            multiple = TRUE
        )
    })

    ## Dynamic selectInput dropdown, BSR leefstijlsegmentatie
    output$select_age <- renderUI({
        input$resetInput
        pickerInput(
            inputId = paste0(x, "age_choice"),
            label = "Age",
            choices = c('0-20', '20-50', '50-80', '80+'),
            selected =  '0-20',
            options = list(`actions-box` = TRUE, `selected-text-format` = "count > 3"),
            multiple = TRUE
        )
    })

    output$egText2 <- renderText({'some content, where filters need to remain identical for subpages of Same'})



}

# UI & SERVER
# ---------------------

ui <- dashboardPage(
    dashboardHeader(), 
    dashboardSidebar(
        sidebarMenu(
            id = "tabs",
            menuItem("Different", tabName = "different"),
            menuItem("Same",
                     menuSubItem("Identical-filter 1", tabName = "same1"),
                     menuSubItem("Identical-filter 2", tabName = "same2")))),
    dashboardBody(
        tabItems(tabItem("different", textOutput('egText')),
                 tabItem("same1", filterPanelUI(id = "id_1")),
                 tabItem("same2", filterPanelUI(id = "id_2"))
        )
    )
)

server <- function(input, output, session) {

    output$egText <- renderText({'some content, which is very different than other 2 pages'})

    callModule(module = filterPanel, id = "id_1", x = "first_")
    callModule(module = filterPanel, id = "id_2", x = "second_")

    storedval <- reactiveValues(input = NULL)

    observeEvent(input$tabs, {
        if(input$tabs == "same1") {
            updatePickerInput(session, inputId = "first_age_choice", selected = input$second_age_choice)
            updatePickerInput(session, inputId = "first_gender_choice", selected = input$second_gender_choice)
        } else if(input$tabs == "same2") {
            updatePickerInput(session, inputId = "second_age_choice", selected = input$first_age_choice)
            updatePickerInput(session, inputId = "second_gender_choice", selected = input$first_gender_choice)
        }
    })

}

shinyApp(ui, server)