Используйте одни и те же фильтры на нескольких страницах

Question

Я создаю панель инструментов, на которой я буду использовать разные страницы с фильтрами и без них. Для одной из страниц я хочу синхронизировать фильтры по всем подстраницам. Я попытался сделать это с модулем, но если я переключаюсь между подстраницей, фильтры-идентификаторы1 и фильтры-идентификаторы сбрасываются.

Это пример того, что я пытаюсь:

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

Прежде всего, вы должны указать другой параметр внутри модуля, иначе несколько входов будут использовать один и тот же идентификатор, что приведет к ошибкам.

Вы можете использовать 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)