toggle controlbar based on tab and action button - r

Question

I'm trying to toggle the control bar using an actionLink in the top right (to basically copy what the gears icon is doing, and later I will remove the gears icon to just have one actionLink) and also to automate the toggling such that when the user clicks on feedback, the controlbar disappears and reappears when the user clicks on any other tab. I also want to make sure throughout this toggling, the controlbar does not overlay on the dashboard body (basically the dashboard body will resize appropriately whenever the control bar toggles).
This is what I've tried so far:
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

There is no need to create a new actionLink and hide the existing a-tag. We can simply modify it.
Please check the following:
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)
Edit: Here is an UI-only approach not using 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)