将多个 subMenuItem 链接到同一个 tabItem 并更新 tabBox？

Question

我正在开发一个 shinydashboard 应用程序并尝试（参见下面的 reprex）将三个不同的 menuSubItems 指向同一个选项卡，同时还更新该选项卡上与用户单击的 menuSubItem 相对应的 tabBox。

基本原理：我正在实施此功能，以便用户可以根据光标所在的位置（即在侧边栏上方或页面上）更轻松地导航到子页面。

当前状态：正如您在下面的代码中看到的，我已经完成了 85%，感谢使用 javascript (tabs_js)。我编写的脚本将单击选项卡 <a> 中的实际文本分配给 input$activeTab，然后使用以更改的 input$activeTab 状态为条件的 observeEvent 更新选定的 tabBox 面板。

问题：由于所有三个 menuSubItems 中的“tabName”都是相同的，因此单击其中任何一个只会显示在侧边栏中单击的第一个（即 aria-selected = true 仅适用于元素 1）。有什么方法可以保留这种多对一子菜单方法并在单击时显示相关子菜单？而且总的来说，有没有更优雅的方法来解决这个问题？

可重现的例子：

library(shiny)
library(shinydashboard)
library(shinyjs)

tabs_js <- '
$(document).ready(function(){
  $("a[data-toggle=tab").click(function(){
     var el = $(this).text().trim();
     Shiny.setInputValue("activeTab", el);
   });
})
'


ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(
    sidebarMenu(id = "side_id",
                menuItem("Boxes", tabName = "boxes", selected = T),
                menuItem("Foxes", tabName = "foxes",
                         menuSubItem("Loxes", tabName = "loxes"),
                         menuSubItem("Roxes", tabName = "loxes"),
                         menuSubItem("Noxes", tabName = "loxes")
                ),
                verbatimTextOutput("selected_tab_text")
    )),
  dashboardBody(
    useShinyjs(),
    tags$head(
      tags$script(HTML(tabs_js))
    ),
    tabItems(
      tabItem(tabName = "boxes",
              tabBox(
                tabPanel("One")
              )),
      tabItem(tabName = "foxes"),
      tabItem(tabName = "loxes",
              tabBox(id = "lox_box",
                     tabPanel("A"),
                     tabPanel("B"),
                     tabPanel("C")
              )
      )
    )
  )
)

server <- function(session, input, output) {
  
  observeEvent(input$activeTab,{
    if(input$activeTab == "Loxes"){
      updateTabItems(session, "lox_box", "A")
    } else if(input$activeTab == "Roxes"){
      updateTabItems(session, "lox_box", "B")
    } else if(input$activeTab == "Noxes"){
      updateTabItems(session, "lox_box", "C")
    }
  })
  
  
  output$selected_tab_text <- renderPrint({
    input$activeTab
    
  })
  
}

shinyApp(ui = ui, server = server)

编辑：

我发现如果通过 renderMenu 呈现边栏的任何元素，javascript 功能就会崩溃（请参阅下面的新 reprex）。那么如何通过JS访问侧边栏菜单中当前的ul / li元素？

library(shiny)
library(shinydashboard)
library(shinyjs)

tabs_js <- '
$(document).ready(function(){
  $("a[data-toggle=tab]").click(function(){
     var el = $(this).text().trim();
     Shiny.setInputValue("activeTab", el);
   });
})
'


ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(
    sidebarMenu(id = "side_id",
                menuItem("Boxes", tabName = "boxes", selected = T),
                menuItemOutput("fox_menu"),
                verbatimTextOutput("selected_tab_text")
    )),
  dashboardBody(
    useShinyjs(),
    tags$head(
      tags$script(HTML(tabs_js))
    ),
    tabItems(
      tabItem(tabName = "boxes",
              tabBox(
                tabPanel("One", actionButton("tog", "Toggle"))
              )),
      tabItem(tabName = "foxes"),
      tabItem(tabName = "loxes",
              tabBox(id = "lox_box",
                     tabPanel("A"),
                     tabPanel("B"),
                     tabPanel("C")
              )
      )
    )
  )
)

server <- function(session, input, output) {
  
  observeEvent(input$activeTab,{
    if(input$activeTab == "Loxes"){
      updateTabItems(session, "lox_box", "A")
    } else if(input$activeTab == "Roxes"){
      updateTabItems(session, "lox_box", "B")
    } else if(input$activeTab == "Noxes"){
      updateTabItems(session, "lox_box", "C")
    }
  })
  
  output$fox_menu <- renderMenu({
    menuItem("Foxes", tabName = "foxes",
             menuSubItem("Loxes", tabName = "loxes"),
             menuSubItem("Roxes", tabName = "loxes"),
             menuSubItem("Noxes", tabName = "loxes")
    )
  })
  
  output$selected_tab_text <- renderPrint({
    input$activeTab
    
  })
  
}

shinyApp(ui = ui, server = server)

Answer 1

我似乎回答了我自己的问题（现在 2/2 了！）。答案主要是基于 JS 的。首先，我将 JS 代码更改为如下所示。它找到活动的 <a>，获取文本，从任何当前 <li> 中删除 'active' class，然后使用户单击的那个成为活动的。

jscode <- "
shinyjs.setVal = function(){
     $('#sidebarCollapsed').find('a[data-toggle=tab]').click(function(){
       var el = $(this).text().trim();
       Shiny.setInputValue('activeTab', el);
   
       var sideb = this;
       
       $('#sidebarCollapsed').find('li.active').removeClass('active');
       $(sideb).closest('li').addClass('active');
   });
};
"

然后我使用 extendShinyjs 将它添加到 dashboardBody。

 dashboardBody(
    useShinyjs(),
    extendShinyjs(text = jscode, functions = c("setVal"))

最后我创建了一个observeEvent来触发JS函数

  observeEvent(input$side_id,{
    js$setVal()
  })

请注意，边栏 ID 是“side_id”。这种方法通过查找其名称触发等于 menuSubItem 的 tabBox 选项卡，并使相关的 <li> 处于活动状态。出于某种原因，这会破坏我编写的复杂模块化应用程序中的选项卡呈现，但那是另一天的事情。

完整产品：

library(shiny)
library(shinydashboard)
library(shinyjs)

jscode <- "
shinyjs.setVal = function(){
     $('#sidebarCollapsed').find('a[data-toggle=tab]').click(function(){
       var el = $(this).text().trim();
       Shiny.setInputValue('activeTab', el);
  
       var sideb = this;
       
       $('#sidebarCollapsed').find('li.active').removeClass('active');
       $(sideb).closest('li').addClass('active');
   });
};
"


ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(
    sidebarMenu(id = "side_id",
                menuItem("Boxes", tabName = "boxes", selected = T),
                menuItemOutput("fox_menu")
    )),
  dashboardBody(
    useShinyjs(),
    extendShinyjs(text = jscode, functions = c("setVal")),
    tabItems(
      tabItem(tabName = "boxes",
              tabBox(
                tabPanel("One", actionButton("tog", "Toggle"))
              )),
      tabItem(tabName = "foxes"),
      tabItem(tabName = "loxes",
              tabBox(id = "lox_box",
                     tabPanel("A"),
                     tabPanel("B"),
                     tabPanel("C")
              )
      )
    )
  )
)

server <- function(session, input, output) {
  
  observeEvent(input$activeTab,{
    if(input$activeTab == "Loxes"){
      updateTabItems(session, "lox_box", "A")
    } else if(input$activeTab == "Roxes"){
      updateTabItems(session, "lox_box", "B")
    } else if(input$activeTab == "Noxes"){
      updateTabItems(session, "lox_box", "C")
    }
  })
  
  output$fox_menu <- renderMenu({
    menuItem("Foxes", tabName = "foxes",
             menuSubItem("Loxes", tabName = "loxes"),
             menuSubItem("Roxes", tabName = "loxes"),
             menuSubItem("Noxes", tabName = "loxes")
    )
  })
  
  observeEvent(input$side_id,{
    js$setVal()
  })

}

shinyApp(ui = ui, server = server)

将多个 subMenuItem 链接到同一个 tabItem 并更新 tabBox？

Linking more than one subMenuItem to the same tabItem and updating tabBox?

javascript

r

shiny

shinydashboard