navbarMenu 内的 navbarMenu 闪亮

Question

如果我在 Shiny 中使用以下 UI，我大致会得到我想要的输出，但它实际上不起作用，因为最低级别的 navbarMenu 显示它的顶级标签和指示它可扩展的箭头，但无法注册子项目。我的猜测是因为这仅被设计为顶级元素（navbarMenu）。我的问题是，是否有另一个元素可以执行子菜单所需的任务？无法在菜单项下分组将很快变得视觉效率低下。

shinyUI(navbarPage("My Application",
                   tabPanel("Component 1"),
                   tabPanel("Component 2"),
                   navbarMenu("More",
                              tabPanel("Sub-Component A"),
                              tabPanel("Sub-Component B"),
                              navbarMenu("Yet More",
                                         tabPanel("Subpart 1"),
                                         tabPanel("Subpart 2"))
                              )
                   )
)

Answer 1

这是一个很好的问题！

我认为您没有其他元素可以使用，但您可以使用 JavaScript 来使其工作。

我对

app.R

所做的唯一更改是包含 js 文件，使用：

includeScript("script.js")

。真正的部分是脚本本身：我们定义了 2 个事件处理程序：

单击下拉菜单

下拉菜单由

navbarMenu

创建。它们没有连接

tabPane

，因此我们需要的只是通过切换下拉菜单（关闭时打开，或处于打开状态时关闭）来重新定义默认行为。

单击选项卡

单击选项卡时需要考虑 3 个子任务：

在选项卡内容中设置活动元素

我们需要显示被单击的相应

tabPane

，以便查看内容。显示带有

tabPane

的

class: active

，因此首先从每个

active

中删除

tabPane

类，然后为单击的选项卡添加

active

类。

在导航栏中设置活动元素

同样的故事，

active

选项卡在

navbar

中以深灰色直观地表示。

关闭所有下拉菜单

单击

navbarMenu

中的特定选项卡后，关闭所有下拉菜单可能是个好主意，否则它们将保持打开状态。

脚本.js

$(document).ready(function(){
  $('.dropdown').on('click', function(e){
    $(this).toggleClass('open');
    
    e.stopPropagation();
    e.preventDefault();
  });
  
  $('[data-toggle=tab]').on('click', function(e){
    let dv = ($(this).attr('data-value'));
    
    //Set active element in tabcontents
    $('.tab-pane').removeClass('active');
    $('.tab-pane[data-value="' + dv + '"]').addClass('active');
    
    //Set active element in navbar
    $('a[data-toggle=tab]').parent().removeClass('active');
    $('a[data-value="' + dv + '"]').parent().addClass("active");
    
    //Close the dropdowns
    $('.dropdown').removeClass('open');
    
    e.stopPropagation();
    e.preventDefault();
  });
});

您可以快速尝试一下

runGist("https://gist.github.com/dgyurko/e1952c5ecbf9a1315b41b8d7ef1f7a8f")

确保在浏览器中进行测试，因为它在 RStudio 查看器中似乎无法正常工作！

演示

Answer 2

GyD 的代码对于除版本 4 之外的所有 bootswatch 版本都可以完美运行，是否有任何解决方法？

library(shiny)

ui <- fluidPage(
  #theme = bs_theme(version = 4,  bootswatch = 'superhero'),
  includeScript("script.js"),
  navbarPage("My Application",
             tabPanel("Component 1", "Component 1"),
             tabPanel("Component 2", "Component 2"),
             navbarMenu("More",
                        tabPanel("Sub-Component A", "Sub-Component A"),
                        tabPanel("Sub-Component B", "Sub-Component B"),
                        navbarMenu("Yet More",
                                   tabPanel("Subpart 1", "Subpart 1"),
                                   tabPanel("Subpart 2", "Subpart 2"))
             )
  )
)

server <- function(input, output, session) {}

shinyApp(ui, server)

这工作得很好，但是这个代码应用程序代替了

library(shiny)

ui <- fluidPage(
  theme = bs_theme(version = 4,  bootswatch = 'superhero'),
  includeScript("script.js"),
  navbarPage("My Application",
             tabPanel("Component 1", "Component 1"),
             tabPanel("Component 2", "Component 2"),
             navbarMenu("More",
                        tabPanel("Sub-Component A", "Sub-Component A"),
                        tabPanel("Sub-Component B", "Sub-Component B"),
                        navbarMenu("Yet More",
                                   tabPanel("Subpart 1", "Subpart 1"),
                                   tabPanel("Subpart 2", "Subpart 2"))
             )
  )
)

server <- function(input, output, session) {}

shinyApp(ui, server)

这不起作用，有什么解决方法吗？