shinydashboard：在 `menuItem` 中包含输入时失去 `tabItem` 响应能力

Question

我有一个仪表板，其中 dashboardBody 中显示的 tabItem 取决于 dashboardMenu 中选择的 menuItem，如下所示：

library(shiny)
library(shinydashboard)

ui <- dashboardPage(dashboardHeader(title = "This works"),
                    dashboardSidebar(
                      sidebarMenu(
                        menuItem("item 1", tabName = "item1", icon = icon("th-list")),
                        menuItem("item 2", tabName = "item2", icon = icon("list-alt"))
                                 )
                      ),
                    dashboardBody(
                      tabItems(
                        tabItem(tabName = "item1",
                                tabsetPanel(id = "tabs1",
                                            tabPanel("Tab1", plotOutput("1")),
                                            tabPanel("Tab2", plotOutput("2"))

                                )),
                        tabItem(tabName = "item2",
                                tabsetPanel(id = "tabs2",
                                            tabPanel("Tab3", plotOutput("3")),
                                            tabPanel("Tab4", plotOutput("4"))
                                            )
                                )
                        )
                      )
                    )

server <- function(input, output) {}

shinyApp(ui, server)

但是，一旦我在 menuItem 中包含输入，此响应就会丢失：

 ui <- dashboardPage(dashboardHeader(title = "This doesn't work"),
                    dashboardSidebar(
                      sidebarMenu(
                        menuItem("item 1", tabName = "item1", icon = icon("th-list"),
                                 checkboxInput("check", label = "check")),
                        menuItem("item 2", tabName = "item2", icon = icon("list-alt"))
                                 )
                      ),
                    dashboardBody(
                      tabItems(
                        tabItem(tabName = "item1",
                                tabsetPanel(id = "tabs1",
                                            tabPanel("Tab1", plotOutput("1")),
                                            tabPanel("Tab2", plotOutput("2"))

                                )),
                        tabItem(tabName = "item2",
                                tabsetPanel(id = "tabs2",
                                            tabPanel("Tab3", plotOutput("3")),
                                            tabPanel("Tab4", plotOutput("4"))
                                            )
                                )
                        )
                      )
                    )

server <- function(input, output) {}

shinyApp(ui, server)

Answer 1

将 this answer 应用于您的示例。这是解决方案：

convertMenuItem <- function(mi,tabName) {
  mi$children[[1]]$attribs['data-toggle']="tab"
  mi$children[[1]]$attribs['data-value'] = tabName
  mi
}

ui <- dashboardPage(dashboardHeader(title = "This works now"),
                    dashboardSidebar(
                      sidebarMenu(
                        convertMenuItem(menuItem("item 1", tabName = "item1", icon = icon("th-list"),
                                                 checkboxInput("check", label = "check")), tabName = "item1"),
                        menuItem("item 2", tabName = "item2", icon = icon("list-alt"))
                      )
                    ),
                    dashboardBody(
                      tabItems(
                        tabItem(tabName = "item1",
                                tabsetPanel(id = "tabs1",
                                            tabPanel("Tab1", plotOutput("1")),
                                            tabPanel("Tab2", plotOutput("2"))

                                )),
                        tabItem(tabName = "item2",
                                tabsetPanel(id = "tabs2",
                                            tabPanel("Tab3", plotOutput("3")),
                                            tabPanel("Tab4", plotOutput("4"))
                                )
                        )
                      )
                    )
)

server <- function(input, output) {}

shinyApp(ui, server)