是否将多个子MenuItem链接到同一tabItem并更新tabBox

Question

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

理由：我正在实现这一点，这样用户就可以更容易地导航到子页面，这取决于他们的光标在哪里，即在侧边栏上或页面上。

当前状态：正如您在下面的代码中所看到的，由于使用javascript(tabs_js)的这种有用的响应，我已经完成了85%的工作。我编写的脚本将单击的选项卡的<a>中的实际文本分配给输入$activeTab，然后根据输入$activeTab状态的变化，使用observeEvent条件更新所选的tabBox面板。

问题：自从"；tabName"；在所有三个菜单中，SubItems都是相同的，点击其中任何一个都只显示侧边栏中点击的第一个(即ariaselected=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

我似乎回答了自己的问题(现在是SO的2/2！)。答案主要是基于JS的。首先，我把JS代码改成这样。它找到活动的<a>，获取文本，从任何当前的<li>中删除"活动"类，然后使用户单击的类处于活动状态。

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)