Hide and show sidebars based on chosen tabPanel in shinydashboard - r

I have the shinydashboard below in which I have 3 tabPanels. In the 1st tabPanel "Resource Allocation" I want the left and right sidebar open by default. In the 2nd and 3rd tabpanels ("Time Series","Longitudinal View") I want only left sidebar and the right sidebar not just hidden but to not be able to open at all by pushing the "gears" icon above it which should be removed. And in the fourth panel "User Guide" I want no sidebar and no choise to open one of them at all.
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
shinyApp(
ui = dashboardPage(
options = list(sidebarExpandOnHover = TRUE),
header = dashboardHeader(
titleWidth = "0px"
),
sidebar = dashboardSidebar(minified = TRUE, collapsed = F),
body = dashboardBody(
useShinyjs(),#tags$head(tags$script(src="format_number.js")),
tags$script("document.getElementsByClassName('sidebar-toggle')[0].style.visibility = 'hidden';"),
tabsetPanel(
tabPanel("Resource Allocation"),
tabPanel("Time Series"),
tabPanel("Longitudinal View"),
tabPanel("User Guide")
)
),
controlbar = dashboardControlbar(collapsed = F),
title = "DashboardPage"
),
server = function(input, output) { }
)

I have a solution for the left sidebar. I am sure you can spend sometime and figure out the solution for the right sidebar. Please note that this requires some more work to fine tune to your needs. Try this
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
library(DT)
ui <- shinydashboardPlus::dashboardPage(
options = list(sidebarExpandOnHover = TRUE),
shinydashboardPlus::dashboardHeader(
#titleWidth = "0px"
),
shinydashboardPlus::dashboardSidebar( disable = TRUE ,
sidebarMenu(
selectInput(
"countries", label = "Select Countries",
choices = c("B", "C", "A"), selected = "A",
multiple = TRUE
))
),# minified = TRUE, collapsed = F),
controlbar = shinydashboardPlus::dashboardControlbar(id = "controlbar", collapsed = F,
skin = "dark",
controlbarMenu(
id = "menu",
controlbarItem(
"Tab 1",
"Welcome to tab 1"
),
controlbarItem(
"Tab 2",
"Welcome to tab 2"
)
)
),
shinydashboard::dashboardBody(
useShinyjs(),
tabsetPanel( id="tabset",
tabPanel("Resource Allocation", value="tab1", plotOutput("plot")),
tabPanel("Time Series", value="tab2", plotOutput("plot2")),
tabPanel("Longitudinal View", value="tab3", DTOutput("ir")),
tabPanel("User Guide", value="tab4", DTOutput("mt"))
)
),
# controlbar = dashboardControlbar(collapsed = F),
title = "DashboardPage"
)
server <- function(input, output) {
output$plot <- renderPlot(plot(cars))
output$plot2 <- renderPlot(plot(pressure))
output$mt <- renderDT(mtcars)
output$ir <- renderDT(iris)
observeEvent(input[["tabset"]], {
if(input[["tabset"]] == "tab4"){
addClass(selector = "body", class = "sidebar-collapse")
updateControlbar("controlbar")
}else{
removeClass(selector = "body", class = "sidebar-collapse")
}
})
}
shinyApp(ui, server)

Related

remove toggle gear icon controlbar

I'm trying to customize how my R shiny app looks like and playing around with various elements on the page.
Just wondering how do I remove this toggle icon from the header? I've tried something like this but it doesn't work:
shinyjs::runjs("document.getElementsByClassName('skin-blue sidebar-mini')[0].style.visibility = 'hidden';")
reproducible example:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
library(DT)
ui <- shinydashboardPlus::dashboardPage(
options = list(sidebarExpandOnHover = TRUE),
header = dashboardHeader(
tags$li(
id = 'right-sidebar-toggle-list-item',
class = "dropdown",
actionLink("rightSidebarToggle", "Select Population"))
),
shinydashboardPlus::dashboardSidebar( disable = TRUE ,
sidebarMenu(
selectInput(
"countries", label = "Select Countries",
choices = c("B", "C", "A"), selected = "A",
multiple = TRUE
))
),# minified = TRUE, collapsed = F),
controlbar = shinydashboardPlus::dashboardControlbar(id = "controlbar", collapsed = F,
skin = "dark",
controlbarMenu(
id = "menu",
controlbarItem(
"Tab 1",
"Welcome to tab 1"
),
controlbarItem(
"Tab 2",
"Welcome to tab 2"
)
)
),
shinydashboard::dashboardBody(
useShinyjs(),
tabsetPanel( id="tabset",
tabPanel("Resource Allocation", value="tab1", plotOutput("plot")),
)
),
# controlbar = dashboardControlbar(collapsed = F),
title = "DashboardPage"
)
server <- function(input, output) {
output$plot <- renderPlot(plot(cars))
}
shinyApp(ui, server)
We can use some JS via tags$script to hide the icon:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
library(DT)
ui <- shinydashboardPlus::dashboardPage(
options = list(sidebarExpandOnHover = TRUE),
shinydashboardPlus::dashboardHeader(
tags$li(
id = 'right-sidebar-toggle-list-item',
class = "dropdown",
actionLink("rightSidebarToggle", "Select Population"))
),
shinydashboardPlus::dashboardSidebar(disable = TRUE ,
sidebarMenu(
selectInput(
"countries",
label = "Select Countries",
choices = c("B", "C", "A"),
selected = "A",
multiple = TRUE
)
)),
# minified = TRUE, collapsed = F),
controlbar = shinydashboardPlus::dashboardControlbar(
id = "controlbar",
collapsed = F,
skin = "dark",
controlbarMenu(
id = "menu",
controlbarItem("Tab 1",
"Welcome to tab 1"),
controlbarItem("Tab 2",
"Welcome to tab 2")
)
),
shinydashboard::dashboardBody(
useShinyjs(),
# hide icon
# tags$script(
# HTML(
# 'var e = document.querySelector("body > div.wrapper > header > nav > div:nth-child(4) > ul > li > a > i");
# e.setAttribute("style", "display: none;");'
# )
# ),
# hide hyperlink
tags$script(HTML('var e = document.querySelector("body > div.wrapper > header > nav > div:nth-child(4) > ul > li:last-child > a");
e.setAttribute("style", "display: none;");')),
tabsetPanel(
id = "tabset",
tabPanel("Resource Allocation", value = "tab1", plotOutput("plot")),
)
),
# controlbar = dashboardControlbar(collapsed = F),
title = "DashboardPage"
)
server <- function(input, output) {
output$plot <- renderPlot(plot(cars))
}
shinyApp(ui, server)

Show output of dashboardBody when rightSidebarTabContent id selected in shinyDashboard

How I am able to show the output of dashboardBody when the id of rightSidebarTabContent selected. If id = "tab_1", selected, show the verbatimTextOutput("tab1") and so on. I used shinyjs::show and shinyjs::hide, but it's not working. Any suggestion?
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- dashboardPagePlus(
header = dashboardHeaderPlus(
enable_rightsidebar = TRUE,
rightSidebarIcon = "gears"
),
sidebar = dashboardSidebar(),
rightsidebar = rightSidebar(
id = "right_sidebar",
background = "dark",
rightSidebarTabContent(
id = "tab_1",
title = "Tab 1",
icon = "desktop",
active = TRUE,
sliderInput(
"obs",
"Number of observations:",
min = 0, max = 1000, value = 500
)
),
rightSidebarTabContent(
id = "tab_2",
title = "Tab 2",
textInput("caption", "Caption", "Data Summary")
),
rightSidebarTabContent(
id = "tab_3",
icon = "paint-brush",
title = "Tab 3",
numericInput("obs", "Observations:", 10, min = 1, max = 100)
)
),
dashboardBody(
div(id = "tab1_out", verbatimTextOutput("tab1")),
div(id = "tab2_out", verbatimTextOutput("tab2")),
div(id = "tab3_out", verbatimTextOutput("tab3"))
)
)
server <- function(input, output) {
output$tab1 <- renderPrint({
"tab1"
})
output$tab2 <- renderPrint({
"tab2"
})
output$tab3 <- renderPrint({
"Tab3"
})
observeEvent(input$right_sidebar,{
if(input$right_sidebar == "tab_1"){
shinyjs::show("tab1_out")
shinyjs::hide("tab2_out")
shinyjs::hide("tab3_out")
}else if(input$right_sidebar == "tab_2"){
shinyjs::hide("tab1_out")
shinyjs::show("tab2_out")
shinyjs::hide("tab3_out")
}else{
shinyjs::hide("tab1_out")
shinyjs::hide("tab2_out")
shinyjs::show("tab3_out")
}
})
}
shinyApp(ui, server)
I am not sure that you can hide and show the body content from right sidebar. However, you can control the outputs in display page. The code below shows that the body content is still controlled by left sidebar, but the plot display can be changed from the right sidebar. For each tabPanel, you can either choose to have a right sidebar or not.
library(shiny)
library(shinydashboard)
library(shinyjs)
library(shinydashboardPlus)
library(ggplot2)
header <- dashboardHeaderPlus(
enable_rightsidebar = TRUE,
rightSidebarIcon = "gears"
)
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Section A", tabName = "Section_A", icon = icon("map")),
menuItem("Section B", tabName = "Section_B", icon = icon("chart-line")),
menuItem("Section C", tabName = "Section_C", icon = icon( "gears")),
id = "nav"
)
)
rightsidebar <- rightSidebar(
shiny::tags$head(shiny::tags$style(shiny::HTML(
".control-sidebar-tabs {display:none;}
.tabbable > .nav > li > a:hover {background-color: #333e43; color:white}
.tabbable > .nav > li[class=active] > a {background-color: #222d32; color:white}"))),
# '{display:none;}' removes empty space at top of rightsidebar
background = "dark",
uiOutput("side_bar"),
title = "Right Sidebar"
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = "Section_A",
p("Some content for section A"),
tabPanel(id = "tab_1o", "Tab 1 for Section A", verbatimTextOutput("tab1"), plotOutput("plot1")),
),
tabItem(
tabName = "Section_B",
p("Some content for section B"),
tabPanel(id = "tab_2o", "Tab 2 for Section B", verbatimTextOutput("tab2"), DTOutput("data2") ),
),
tabItem(
tabName = "Section_C",
p("Some content for section C"),
tabPanel(id = "tab_3o", "Tab 3 for Section C", verbatimTextOutput("tab3"), plotOutput("plot3"))
)
),
tags$script(
'$("a[data-toggle=\'tab\']").click(function(){
Shiny.setInputValue("tabactive", $(this).data("value"))
})'
)
)
ui <- tags$body(class="skin-blue sidebar-mini control-sidebar-open", dashboardPagePlus( ## keep the right sidebar open permanently
#ui <- dashboardPagePlus(
shinyjs::useShinyjs(),
header = header,
sidebar = sidebar,
body = body,
rightsidebar = rightsidebar
)
)
server <- function(input, output) {
output$tab1 <- renderPrint({
"tab1"
})
output$plot1 <- renderPlot({
set.seed(122)
histdata <- rnorm(500)
data <- histdata[seq_len(req(input$obs1))]
hist(data)
})
output$tab2 <- renderPrint({
"tab2"
})
output$plot2 <- renderPlot(qplot(rnorm(500),fill=I("green"),binwidth=0.2,title="plotgraph2"))
output$data2 <- renderDT(datatable(iris))
output$tab3 <- renderPrint({
"Tab3"
})
output$plot3 <- renderPlot(qplot(rnorm(req(input$obs3)),fill=I("blue"),binwidth=0.2,title="plotgraph3"))
observe({
if (req(input$nav) == "Section_A"){
message("tab_1 has been selected")
#shinyjs::addClass(selector = "aside.control-sidebar", class = "control-sidebar-open")
shinyjs::removeClass(selector = "aside.control-sidebar", class = "control-sidebar-open")
output$side_bar <- renderUI({
rightSidebarTabContent(
id = "tab_1",
title = "Right sidebar for Section A ",
icon = "desktop",
#active = TRUE,
sliderInput(
"obs1",
"Number of observations:",
min = 0, max = 1000, value = 500
)
)
})
}
if (req(input$nav) == "Section_B"){
message("tab_2 has been selected")
#shinyjs::addClass(selector = "aside.control-sidebar", class = "control-sidebar-open") ## to add right sidebar
shinyjs::removeClass(selector = "aside.control-sidebar", class = "control-sidebar-open") ## remove right sidebar
output$side_bar <- renderUI({
rightSidebarTabContent(
id = "tab_2",
title = "Right sidebar for Section B ",
textInput("caption", "Caption", "Data Summary")
)
})
}
if (req(input$nav) == "Section_C"){
message("tab_3 has been selected")
#shinyjs::addClass(selector = "aside.control-sidebar", class = "control-sidebar-open")
shinyjs::removeClass(selector = "aside.control-sidebar", class = "control-sidebar-open")
output$side_bar <- renderUI({
rightSidebarTabContent(
id = "tab_3",
icon = "paint-brush",
title = "Right sidebar for Section C",
numericInput("obs3", "Observations:", 400, min = 1, max = 1000)
)
})
}
})
}
shinyApp(ui, server)

How to make the size of icon consistent when using Shiny and Shinydashboard?

I am adding clickable icons in my shiny app to show a popup information box. Please see the following screenshot and code example. My strategy is to wrap my text and the code for actionLink in the HTML function. This works well. However, the size of the icon is determined by the size of the associated. I would like to know if it is possible to make all the icons the same size, such as the smallest one associated with the selectInput?
The documentation (https://shiny.rstudio.com/reference/shiny/1.0.1/icon.html) mentioned that it is to set "fa-3x" in the icon function to make the size to be 3 times as normal. But in my case the size would sill be determined by the associated text and each text has a different size. So I guess this strategy would not work. It would be great if anyone can share their ideas or suggestions.
# Load the packages
library(shiny)
library(shinydashboard)
library(shinyalert)
# User Interface
ui <- dashboardPage(
header = dashboardHeader(title = ""),
sidebar = dashboardSidebar(
sidebarMenu(
menuItem(
text = "Example",
tabName = "tab1"
)
)
),
body = dashboardBody(
# A call to use the shinyalert package
useShinyalert(),
tabItems(
tabItem(
tabName = "tab1",
h2(HTML("This is a title",
as.character(actionLink(inputId = "info1",
label = "",
icon = icon("info"))))),
fluidRow(
box(
title = HTML("This is the title of the box",
as.character(actionLink(inputId = "info2",
label = "",
icon = icon("info")))),
status = "primary", solidHeader = TRUE,
selectInput(inputId = "Select",
label = HTML("This is the title of the selectInput",
as.character(actionLink(inputId = "info3",
label = "",
icon = icon("info")))),
choices = 1:3)
)
)
)
)
)
)
server <- function(input, output, session){
observeEvent(input$info1, {
shinyalert(text = "Info 1", type = "info")
})
observeEvent(input$info2, {
shinyalert(text = "Info 2", type = "info")
})
observeEvent(input$info3, {
shinyalert(text = "Info 3", type = "info")
})
}
# Run the app
shinyApp(ui, server)
I'm not sure if I understand your question correctly but if you want the them all to have the same size you can adapt the font size for the icons like this:
# Load the packages
library(shiny)
library(shinydashboard)
library(shinyalert)
# User Interface
ui <- dashboardPage(
header = dashboardHeader(title = ""),
sidebar = dashboardSidebar(
sidebarMenu(
menuItem(
text = "Example",
tabName = "tab1"
)
)
),
body = dashboardBody(
# A call to use the shinyalert package
useShinyalert(),
tabItems(
tabItem(
tabName = "tab1",
h2(HTML("This is a title", "<font size='3'>",
as.character(actionLink(inputId = "info1",
label = "",
icon = icon("info"))), "</font>")),
fluidRow(
box(
title = HTML("This is the title of the box", "<font size='3'>",
as.character(actionLink(inputId = "info2",
label = "",
icon = icon("info"))), "</font>"),
status = "primary", solidHeader = TRUE,
selectInput(inputId = "Select",
label = HTML("This is the title of the selectInput", "<font size='3'>", as.character(actionLink(inputId = "info3",
label = "",
icon = icon("info"))), "</font>"
),
choices = 1:3)
)
)
)
)
)
)
server <- function(input, output, session){
observeEvent(input$info1, {
shinyalert(text = "Info 1", type = "info")
})
observeEvent(input$info2, {
shinyalert(text = "Info 2", type = "info")
})
observeEvent(input$info3, {
shinyalert(text = "Info 3", type = "info")
})
}
# Run the app
shinyApp(ui, server)

Leafletoutput does not show in dashboardBody

Hi I am using shinydashboard to build some visualization for some raster files. I am use leafletOutput to display the map.
Under the first tabItem, where it is called 'KmeansOutput', I would like to display the leaflet map. When I do not include selectInput, it display the map, but once I include the selectInput, it do not display the map. I am not sure which part went wrong. Thanks in advance!!
Here is the UI section of the code:
library(shinydashboard)
library(leaflet)
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("KmeansOutput", tabName = "kmeans", icon = icon("kmeans"),
selectInput("run1",
"SoilAllWeatherAll",
choices = c('4' = 1, '5' = 2),
multiple = TRUE)
),
menuItem("HistoricalWeather", icon = icon("weather"), tabName = "weather"),
menuItem("SoilMap", icon = icon("soil"), tabName = "soil")
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "kmeans",
leafletOutput("map", height = 700)
),
tabItem(tabName = "weather",
h2("weather")),
tabItem(tabName = "soil",
h2('soil'))
)
)
# Put them together into a dashboardPage
ui <- dashboardPage(
dashboardHeader(title = "Genome Prediction"),
sidebar,
body)
here is the server:
server <- function(input, output) {
output$map <- renderLeaflet({
leaflet() %>%
addTiles()
})
}
shinyApp(ui, server)
You need to add a sub-item to your k-means siderbar item as follows.
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("KmeansOutput", #icon = icon("kmeans"),
menuSubItem(
"K-Means Map", tabName = "kmeans", icon = icon("calendar")
),
selectInput("run1",
"SoilAllWeatherAll",
choices = c('4' = 1, '5' = 2),
multiple = TRUE)
),
menuItem("HistoricalWeather", tabName = "weather"), #icon = icon("weather"),
menuItem("SoilMap", tabName = "soil")#, icon = icon("soil")
)
)

Show/hide menuItem in shinydashboard

I need a menuItem hidden, when the app is entered into. When a user chooses a certain value, the menuItem has to appear.
I have tried shinyjs functions hidden, and it hides a menuItem, but when using show or toggle, a menuItem doesn't appear.
I've found R shinydashboard - show/hide multiple menuItems based on user input
and came up with this
library(shiny)
library(shinydashboard)
library(shinyjs)
header <- dashboardHeader(title = "APP", titleWidth = 330)
sidebar <- dashboardSidebar(
sidebarMenu(id="tabs",
menuItem("",tabName="default"),
menuItem("Scenarios",tabName = "scenarios", icon = icon("flag")),
uiOutput("recOpt"),
menuItem("Simulation", tabName = "game", icon = icon("gamepad")),
menuItem("Actions", tabName = "actions", icon = icon("folder"),
menuSubItem("Save project", tabName = "save"),
menuSubItem("Open project", tabName = "open")
)
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "scenarios",
useShinyjs(),
radioButtons("radio", h3("Radio buttons"),
choices = list("Choice 1" = 1,
"Choice 2" = 2,
"Choice 3" = 3))
)
)
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
output$recOpt <- renderUI({
if(input$radio == 2)
menuItem("Options", tabName = "recOpt", icon = icon("bell"),
menuSubItem("No option",tabName="RO_00"),
menuSubItem("Option 1",tabName="RO_01")
)
})
}
shinyApp(ui, server)
It works but the hidden/shown item is not aligned correcty, nor the encoding is correct.
Have any ideas how to make it better?
A little late, but anyway:
Check the shinydashboard capabilities on dynamic content.
This should do it:
library(shiny)
library(shinydashboard)
library(shinyjs)
header <- dashboardHeader(title = "APP", titleWidth = 330)
sidebar <- dashboardSidebar(
sidebarMenu(id="tabs",
menuItem("",tabName="default"),
menuItem("Scenarios",tabName = "scenarios", icon = icon("flag")),
menuItemOutput("recOpt"),
menuItem("Simulation", tabName = "game", icon = icon("gamepad")),
menuItem("Actions", tabName = "actions", icon = icon("folder"),
menuSubItem("Save project", tabName = "save"),
menuSubItem("Open project", tabName = "open")
)
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "scenarios",
useShinyjs(),
radioButtons("radio", h3("Radio buttons"),
choices = list("Choice 1" = 1,
"Choice 2" = 2,
"Choice 3" = 3))
)
)
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
output$recOpt <- renderMenu({
if(input$radio == 2)
menuItem("Options", tabName = "recOpt", icon = icon("bell"),
menuSubItem("No option",tabName="RO_00"),
menuSubItem("Option 1",tabName="RO_01")
)
})
}
shinyApp(ui, server)

Resources