我正在创建一个仪表板,在其中将使用带有和不带有过滤器的不同页面。对于其中一个页面,我想在所有子页面上同步过滤器。我用一个模块尝试过此操作,但是如果我在子页面之间切换,则会重置相同过滤器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)
有人知道我该怎么做吗?
谢谢!
答案 0 :(得分:0)
首先,您应该在模块内部提供另一个参数,否则多个输入将共享相同的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)