基于选项卡和操作按钮切换控制栏

Question

我正在尝试使用右上角的 actionLink 来切换控制栏（基本上复制齿轮图标的作用，稍后我将删除齿轮图标以只有一个 actionLink）以及自动化切换使得当用户单击反馈时，控制栏消失并在用户单击任何其他选项卡时重新出现。我还想确保在整个切换过程中，控制栏不会覆盖仪表板主体（基本上，只要控制栏切换，仪表板主体就会适当调整大小）。

这是我目前尝试过的方法：

library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
library(shinyjs)

ui <-  dashboardPage(
    title = 'Test',
    header = dashboardHeader(
      title = span("Test"),
      titleWidth = 600,
      tags$li(
        id = 'right-sidebar-toggle-list-item',
        class = "dropdown",
        actionLink("rightSidebarToggle", "Select Population"))
      
    ), # end of dashboardheader
    
    sidebar = dashboardSidebar(
      sidebarMenu(id = "sidebar",
                  menuItem("Overview", tabName = "introduction", icon = icon("info")),
    menuItem("Feedback", tabName = "feedback", icon = icon("info")))),
       body = dashboardBody(plotOutput("cars")),
                            controlbar = dashboardControlbar(
                              id = "controlbar",
                              width = 270,
                              skin = "light",
                              collapsed = F,
                              overlay = F,
                              controlbarMenu(
                                id = "menu",
                                controlbarItem(
                                  ' ',
                                  # - select study
                                  checkboxGroupButtons(
                                    inputId = "select_study",
                                    label = "Select Study",
                                    choiceNames = c("1", "2"),
                                    choiceValues = c("1", "2"),
                                    selected = c("1", "2"),
                                    justified = TRUE,
                                    status = "primary",
                                    direction = "vertical",
                                    checkIcon = list(yes = icon("ok", lib = "glyphicon"))
                                  ),
                                )
                              )
                            )
  )
  

server <- function(input, output, session) {
  
  output$cars <- renderPlot({
 plot(mtcars)
  })
  
  # event to toggle right sidebar menu
  observeEvent(input$rightSidebarToggle, {
    shinyjs::toggleClass(selector = "aside.control-sidebar", class = "control-sidebar-open")
})
  
  ##### > Controlbar Collapse #####
  
  observeEvent(input[["sidebar"]], {
    if(input[["sidebar"]] == "feedback"){
      removeClass(selector = "aside.control-sidebar", class = "control-sidebar-open")
    }else{
      addClass(selector = "aside.control-sidebar", class = "control-sidebar-open")
      updateControlbar("controlbar")
    }
  })
}
shinyApp(ui, server)

Answer 1

无需创建新的 actionLink 并隐藏现有的 a-tag。我们可以简单修改一下。

请检查以下内容：

library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
library(shinyjs)

ui <-  dashboardPage(
  title = 'Test',
  header = dashboardHeader(
    title = span("Test"),
    titleWidth = 600,
    controlbarIcon = NULL
  ),
  sidebar = dashboardSidebar(sidebarMenu(
    id = "sidebar",
    menuItem("Overview", tabName = "introduction", icon = icon("info")),
    menuItem("Feedback", tabName = "feedback", icon = icon("info"))
  )),
  body = dashboardBody(
    useShinyjs(),
    tags$script(
      HTML(
        "var el = document.querySelector('body > div > header > nav > div:nth-child(4) > ul > li:last-child > a');
             el.innerHTML = 'Select Population';"
      )
    ),
    plotOutput("cars")
  ),
  controlbar = dashboardControlbar(
    id = "controlbar",
    width = 270,
    skin = "light",
    collapsed = FALSE,
    overlay = FALSE,
    controlbarMenu(id = "menu",
                   controlbarItem(' ',
                                  checkboxGroupButtons(
                                    inputId = "select_study",
                                    label = "Select Study",
                                    choiceNames = c("1", "2"),
                                    choiceValues = c("1", "2"),
                                    selected = c("1", "2"),
                                    justified = TRUE,
                                    status = "primary",
                                    direction = "vertical",
                                    checkIcon = list(yes = icon("ok", lib = "glyphicon"))
                                  )
                   )
    )
  )
)

server <- function(input, output, session) {
  output$cars <- renderPlot({
    plot(mtcars)
  })
  
  observeEvent(input[["sidebar"]], {
    if (input[["sidebar"]] == "feedback") {
      removeClass(selector = "body", class = "control-sidebar-open")
      shinyjs::runjs('Shiny.setInputValue(id = "controlbar", value = false);
                      $(window).trigger("resize");')
    } else {
      addClass(selector = "body", class = "control-sidebar-open")
      shinyjs::runjs('Shiny.setInputValue(id = "controlbar", value = true);
                      $(window).trigger("resize");')
    }
  }, ignoreInit = FALSE)
}
shinyApp(ui, server)

编辑：这是一个 UI-only 不使用 library(shinyjs) 的方法：

library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)

ui <-  dashboardPage(
  title = 'Test',
  header = dashboardHeader(
    title = span("Test"),
    titleWidth = 600,
    controlbarIcon = NULL
  ),
  sidebar = dashboardSidebar(sidebarMenu(
    id = "sidebar",
    menuItem("Overview", tabName = "introduction", icon = icon("info")),
    menuItem("Feedback", tabName = "feedback", icon = icon("info"))
  )),
  body = dashboardBody(
    tags$script(
      HTML(
          "var el = document.querySelector('body > div > header > nav > div:nth-child(4) > ul > li:last-child > a');
             el.innerHTML = 'Select Population';
          $(document).on('shiny:connected', function(event) {
            $(window).trigger('resize'); // resize once on session start - needed when using collapsed = FALSE
          });
          $(document).on('shiny:inputchanged', function(event) {
            if (event.name === 'sidebar') {
              if (event.value === 'feedback') {
                document.querySelector('body').classList.remove('control-sidebar-open');
                Shiny.setInputValue(id = 'controlbar', value = false);
                $(window).trigger('resize');
              } else {
                document.querySelector('body').classList.add('control-sidebar-open');
                Shiny.setInputValue(id = 'controlbar', value = true);
                $(window).trigger('resize');
              }
            }
          });"
      )
    ),
    plotOutput("cars")
  ),
  controlbar = dashboardControlbar(
    id = "controlbar",
    width = 270,
    skin = "light",
    collapsed = FALSE,
    overlay = FALSE,
    controlbarMenu(id = "menu",
                   controlbarItem(' ',
                                  checkboxGroupButtons(
                                    inputId = "select_study",
                                    label = "Select Study",
                                    choiceNames = c("1", "2"),
                                    choiceValues = c("1", "2"),
                                    selected = c("1", "2"),
                                    justified = TRUE,
                                    status = "primary",
                                    direction = "vertical",
                                    checkIcon = list(yes = icon("ok", lib = "glyphicon"))
                                  )
                   )
    )
  )
)

server <- function(input, output, session) {
  output$cars <- renderPlot({
    plot(mtcars)
  })
}
shinyApp(ui, server)

基于选项卡和操作按钮切换控制栏

toggle controlbar based on tab and action button

r

shiny

shinydashboard

shinyjs

shinydashboardplus