Переключение между menuSubItems в shinyDashboard

Question

Я пытаюсь настроить блестящее приложение с помощью shinydashboard и по большей части, имея удачу. Тем не менее, я сталкиваюсь с причудой с поведением боковых панелей, которое, как мне кажется, можно избежать, но пока не нашел.

Ниже приведен небольшой пример, который воспроизводит проблему, которую я испытываю. В принципе, есть два sidebarMenus - Меню Один и Меню Два, каждый с двумя menuSubItems. Переключение подэлементов в элемент меню отлично работает. Итак, если бы я хотел переключиться с subItemOne на subItemTwo, никаких проблем. Я могу делать это весь день.

Я также могу переключиться на subItems в меню, например, чтобы перейти от subItemOne к subItemThree, это нормально. Проблема заключается в попытке вернуться назад. Если subItemOne выбран, и я пытаюсь перейти к subItemThree и назад в subItemOne, я не могу этого сделать. Мне нужно перейти к subItemTwo, затем я могу открыть SubItemOne.

Есть ли способ исправить эту настройку, чтобы я мог перейти непосредственно из subItemOne в subItemThree (или два и четыре) и обратно?

library('shiny') 
library('shinydashboard') 
# Sidebar ############################# 
sidebar <- dashboardSidebar(
    width = 290, 

    sidebarMenu(
    menuItem('Menu One', tabName = 'menuOne', icon = icon('line-chart'), 
     collapsible = 
      menuSubItem('Sub-Item One', tabName = 'subItemOne'), 
      menuSubItem('Sub-Item Two', tabName = 'subItemTwo') 
      ) 
), 

    sidebarMenu(
    menuItem('Menu Two', tabName = 'menuTwo', icon = icon('users'), 
      collapsible = 
       menuSubItem('Sub-Item Three', tabName = 'subItemThree'), 
      menuSubItem('Sub-Item Four', tabName = 'subItemFour') 
    ) 
) 

) 
# Body ############################# 
body <- dashboardBody(

    tabItems(
    tabItem(tabName = 'subItemOne', 
      h2('Selected Sub-Item One') 
    ), 
    tabItem(tabName = 'subItemTwo', 
      h2('Selected Sub-Item Two') 
    ), 
    tabItem(tabName = 'subItemThree', 
      h2('Selected Sub-Item Three') 
    ), 
    tabItem(tabName = 'subItemFour', 
      h2('Selected Sub-Item Four') 
    ) 
) 
) 
# UI ############################# 
ui <- dashboardPage(
    dashboardHeader(title = 'Test', titleWidth = 290), 
    sidebar, 
    body 
) 
# Server ############################# 
server <- function(input, output){ 

} 

shinyApp(ui, server) 

Answer 1

Проблема в том, что элементы табуляции остаются активными и нажатие на активную вкладку не обновляет пользовательский интерфейс. Это можно исправить с помощью некоторого Javascript.

library('shiny') 
library('shinydashboard') 
# Sidebar ############################# 
sidebar <- dashboardSidebar(
    tags$head(
    tags$script(
     HTML(
     " 
     $(document).ready(function(){ 
      // Bind classes to menu items, easiet to fill in manually 
      var ids = ['subItemOne','subItemTwo','subItemThree','subItemFour']; 
      for(i=0; i<ids.length; i++){ 
      $('a[data-value='+ids[i]+']').addClass('my_subitem_class'); 
      } 

      // Register click handeler 
      $('.my_subitem_class').on('click',function(){ 
      // Unactive menuSubItems 
      $('.my_subitem_class').parent().removeClass('active'); 
      }) 
     }) 
     " 
    ) 
    ) 
), 
    width = 290, 

    sidebarMenu(
    menuItem('Menu One', tabName = 'menuOne', icon = icon('line-chart'), 
      collapsible = 
       menuSubItem('Sub-Item One', tabName = 'subItemOne'), 
      menuSubItem('Sub-Item Two', tabName = 'subItemTwo') 
    ) 
), 

    sidebarMenu(
    menuItem('Menu Two', tabName = 'menuTwo', icon = icon('users'), 
      collapsible = 
       menuSubItem('Sub-Item Three', tabName = 'subItemThree'), 
      menuSubItem('Sub-Item Four', tabName = 'subItemFour') 
    ) 
) 

) 
# Body ############################# 
body <- dashboardBody(

    tabItems(
    tabItem(tabName = 'subItemOne', 
      h2('Selected Sub-Item One') 
    ), 
    tabItem(tabName = 'subItemTwo', 
      h2('Selected Sub-Item Two') 
    ), 
    tabItem(tabName = 'subItemThree', 
      h2('Selected Sub-Item Three') 
    ), 
    tabItem(tabName = 'subItemFour', 
      h2('Selected Sub-Item Four') 
    ) 
) 
) 
# UI ############################# 
ui <- dashboardPage(
    dashboardHeader(title = 'Test', titleWidth = 290), 
    sidebar, 
    body 
) 
# Server ############################# 
server <- function(input, output){ 

} 

shinyApp(ui, server)