How do i include input widgets under menuSubItem in shiny dashboard sidebar? - r

How is it possible to include a control widget under the menuSubItem in the sidebar of a shiny app?
This is my trial:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
ui <- dashboardPage(
### Header -----
dashboardHeader(title = "Example App"),
### Sidebar -----
dashboardSidebar(
sidebarMenu(
menuItem(
text = "A",
tabName = "analytics",
icon = icon("signal"),
startExpanded = TRUE,
menuSubItem(text = "a",
icon = NULL,
pickerInput(
inputId = "Id086",
label = "Placeholder",
choices = c("a", "b", "c", "d"),
options = list(
title = "This is a placeholder")
)
),
menuSubItem(text = "b",
icon = NULL)
)
)
),
dashboardBody(
)
)
## Server-function -----
server <- function(input, output) {
}
# Run the application
shinyApp(ui = ui, server = server)
However, the desired input does not appear within the app. I managed it to include the input widget under any of the menu items but i failed to make it appear under menuSubItems.

menuSubItems are intended to navigate tabItems in the body - that is why they can't have child elements.
You can use nested menuItems to place additional inputs in the sidebar (please see the below example) which "behave" differently when childfull / childless.
When a menuItem is childfull it accepts the parameters expandedName and startExpanded.
When a menuItem is childless it accepts the parameters tabName and selected.
A menuSubItem is always childless.
library(shiny)
library(shinyWidgets)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Example App"),
dashboardSidebar(sidebarMenu(
menuItem(
text = "A",
# tabName = "analytics", # childfull menuItems ignore the tabName parameter they use expandedName instead
icon = icon("signal"),
startExpanded = TRUE,
menuItem(
text = "a",
menuSubItem(
text = "a1",
tabName = "tab_a1",
icon = NULL
),
pickerInput(
inputId = "Id086",
label = "Placeholder",
choices = c("a", "b", "c", "d"),
options = list(title = "This is a placeholder")
),
icon = NULL,
startExpanded = TRUE
),
menuSubItem(
text = "b",
tabName = "tab_b",
icon = NULL
)
)
)),
dashboardBody(tabItems(
tabItem(tabName = "tab_a1",
h2("tab_a1 content")),
tabItem(tabName = "tab_b",
h2("tab_b content"))
))
)
server <- function(input, output) {
}
shinyApp(ui = ui, server = server)
Here you can find a related question.
However, personally I'd recommend using shinydashboardPlus's right sidebar for inputs and use the left sidebar only for navigation.

Related

Create a reactive variable depending on active Tab on R Shiny

I have this simple app and I would like to be able to "catch" the active tab.
For example, if I'm on "tab1", my selectInput at the top would be c("a","b","c") but it would change if I am on the other tab
I want to create a variable active_tab that would be dynamic but I have no idea how to do it.
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
title="Shiny Dashboard",
header = shinydashboardPlus::dashboardHeader(
title = "Example",
leftUi = tagList(
uiOutput("reactive_ui")
)),
sidebar = dashboardSidebar(
sidebarMenu(
menuItem("tab1",tabName = "tab1"),
menuItem("tab2",tabName = "tab2")
)
),
body = dashboardBody(
tabItems(
tabItem("tab1"),
tabItem("tab2")
)
)
),
server = function(input, output) {
output$reactive_ui =renderUI({
if (active_tab == "tab1") choice = c("a","b","c","d")
if (active_tab == "tab2") choice = c("e","f","g")
selectInput("select", NULL,choices = choice )
})
}
)
sidebarMenu contains an id parameter that can be used to retrieve the name of the active tab on the server side.
If it is just the selectInput you want to update on the tab change, then have a look at updateSelectInput so that you can update the choices without having to re-render the input every time the tab changes. It also means the input is defined once the application opens.
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
title = "Shiny Dashboard",
header = shinydashboardPlus::dashboardHeader(
title = "Example",
leftUi = tagList(
selectInput("select", NULL, choices = c("a", "b", "c", "d"))
)
),
sidebar = dashboardSidebar(
sidebarMenu(
id = "tab",
menuItem("tab1", tabName = "tab1"),
menuItem("tab2", tabName = "tab2")
)
),
body = dashboardBody(
tabItems(
tabItem("tab1"),
tabItem("tab2")
)
)
),
server = function(input, output, session) {
observeEvent(input$tab, {
if (input$tab == "tab1") {
choices <- c("a", "b", "c", "d")
} else if (input$tab == "tab2") {
choices <- c("e", "f", "g")
}
updateSelectInput(session, "select", choices = choices)
})
}
)

Hide and show sidebars based on chosen tabPanel in shinydashboard

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)

Shiny dataTableOutput won't show up if its is under tabItem

My Shiny APP has a simple structure looks like:
ui <- fluidPage(
dashboardPage(
dashboardHeader(title = "My App"),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard",
selectInput('location', 'Please Select a Location', choices= c("A", "B", "C")),
downloadButton(outputId = 'download', lable = "Downlaod"),
menuItem("Widgets", tabName = "widgets", badgeLabel = "new", badgeColor = "green")
)),
# dashboardBody first try (works no problem):
dashboardBody(DT::dataTableOutput(outputId = 'mytable'))
# dashboardBody second try (data table does not appear):
dashboardBody(
tabItems(
tabItem(tabName = "dashboard",
DT::dataTableOutput(outputId = 'mytable')),
tabItem(tabName = "widgets",
h2("Widgets tab content"))
)))
server <- shinyServer(function(input, output, session){
output$mytable<- DT::renderDataTable({```some calculation```})
output$downloadcsv <- downloadHandler(
filename = function(){paste0(sys.Date(),'-mytable.csv')},
content = function(file) {write.csv(```the table from renderDataTable step```, file)}
)}
As you can see, the app includes two different "pages" where the first one is a data table depends on the selectInput.
My app runs perfectly if I don't wrap it with tabItem. However, once I write it under tabItem, the app only shows "Widgets tab content" which is the content of the second tab and does not populate the data table at all (while the download button still works).
I've also tried to add class='active' behind tabName = "dashboard", but it still doesn't work. Plus, I'm not getting any error message.
I'm wondering if anyone knows which step did I go wrong? Any help would be appreciated!
The problem lies in the placement of the table. I have rendered input options outside the menuItem. Check this code below
ui <- fluidPage(
dashboardPage(
dashboardHeader(title = "My App"),
dashboardSidebar(
sidebarMenu(
selectInput('location', 'Please Select a Location', choices= c("A", "B", "C")),
downloadButton(outputId = 'download.csv', lable = "Downlaod"),
menuItem("Dashboard", tabName = "dashboard"),
menuItem("Widgets", tabName = "widgets", badgeLabel = "new", badgeColor = "green")
)),
# dashboardBody first try (works no problem):
#dashboardBody(DT::dataTableOutput(outputId = 'mytable'))
#dashboardBody second try (data table does not appear):
dashboardBody(
tabItems(
tabItem(tabName = "dashboard",
DT::dataTableOutput(outputId = 'mytable')),
tabItem(tabName = "widgets",
h2("Widgets tab content"))
))
))
server <- function(input, output, session){
output$mytable<- DT::renderDataTable({DT::datatable(head(iris))})
output$downloadcsv <- downloadHandler(
filename = function(){paste0(sys.Date(),'-mytable.csv')},
content = function(file) {write.csv(head(iris), file)}
)}
shinyApp(ui=ui, server=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)

Why can't I go back to a previously viewed page in shiny?

I would like to know why when a open a page (a1) in my shiny app and then I open another page (for example a2) then I can't come back to a1?
To reproduce my example please follow these steps:
click on a2
click on b1
click on c1
click on c8
click on c1 again
I would expect to see the content of c1 again ("example of text 2"), but clicking c1 again appears to do nothing.
library(shinydashboard)
library(shiny)
sidebar <- dashboardSidebar(
tags$head(tags$style(
HTML('.content-wrapper { height: 1500px !important;}')
)),
hr(),
sidebarMenu(
id = "tabs",
menuItem(
"a1",
tabName = "principal",
icon = icon("pagelines"),
selected = TRUE
),
menuItem(
"a2",
icon = icon("chart-bar"),
menuSubItem("b1", tabName = "identificacion", icon = icon("angle-right")),
menuSubItem("b2", tabName = "comunicacion", icon = icon("angle-right")),
menuSubItem("b3", tabName = "medicamentos", icon = icon("angle-right")),
menuSubItem("b4", tabName = "cirugias", icon = icon("angle-right")),
menuSubItem("b5", tabName = "infecciones", icon = icon("angle-right")),
menuSubItem("b6", tabName = "caidas", icon = icon("angle-right"))
),
menuItem("a3", tabName = "procesos", icon = icon("chart-bar")),
menuItem("a4", tabName = "tiempos", icon = icon("chart-bar")),
menuItem("a5", tabName = "manual", icon = icon("mortar-board")),
menuItem("a6", tabName = "acerca", icon = icon("question"))
),
width = 285,
hr(),
conditionalPanel("input.tabs=='identificacion'",
fluidRow(
column(1),
column(
10,
menuItem(
"c1",
tabName = "admision_iden",
icon = icon("chart-line"),
selected = FALSE
),
menuItem(
"c8",
tabName = "uci_iden",
icon = icon("chart-line"),
selected = FALSE
)
)
))
)
body <- dashboardBody(tabItems(
tabItem(tabName = "principal",
withMathJax(), ("example of text")),
tabItem(tabName = "admision_iden", titlePanel("example1"), "example of text 2"),
tabItem(tabName = "uci_iden", titlePanel("example 2"), "example of text 3")
))
ui <- dashboardPage(dashboardHeader(title = "Indic", titleWidth = 285),
sidebar,
body)
server <- function(input, output) {}
runApp(list(ui = ui, server = server))
Your additional menus are rendered outside sidebarMenu, so when selected, their ids are not recorded in the input variable input$tabs (which is what the app is monitoring). Including the menus inside sidebarMenu allows the tabItems to track the menuItems, but also breaks the reactivity, i.e., when input$tabs == 'uci_iden' the additional menus disappear (because input$tabs != 'identificacion').
One way to achieve the behavior you want (possibly not the best way) is to render the additional menus through the server using renderUI. Note that we still have to include the additional menus inside sidebarMenu and monitor them through input$tabs. To make sure they stick around when input$tabs != 'identificacion', we can include their ids in the condition. When neither of identification, uni_iden or admision_iden are selected, we render an empty div.
Updated code:
library(shinydashboard)
library(shiny)
sidebar <- dashboardSidebar(
tags$head(tags$style(
HTML('.content-wrapper { height: 1500px !important;}')
)),
hr(),
sidebarMenu(
id = "tabs",
menuItem(
"a1",
tabName = "principal",
icon = icon("pagelines"),
selected = TRUE
),
menuItem(
"a2",
icon = icon("chart-bar"),
menuSubItem("b1", tabName = "identificacion", icon = icon("angle-right")),
menuSubItem("b2", tabName = "comunicacion", icon = icon("angle-right")),
menuSubItem("b3", tabName = "medicamentos", icon = icon("angle-right")),
menuSubItem("b4", tabName = "cirugias", icon = icon("angle-right")),
menuSubItem("b5", tabName = "infecciones", icon = icon("angle-right")),
menuSubItem("b6", tabName = "caidas", icon = icon("angle-right"))
),
menuItem("a3", tabName = "procesos", icon = icon("chart-bar")),
menuItem("a4", tabName = "tiempos", icon = icon("chart-bar")),
menuItem("a5", tabName = "manual", icon = icon("mortar-board")),
menuItem("a6", tabName = "acerca", icon = icon("question")),
width = 285,
hr(),
uiOutput("more_menus")
)
)
body <- dashboardBody(tabItems(
tabItem(tabName = "principal",
withMathJax(), ("example of text")),
tabItem(tabName = "admision_iden", titlePanel("example1"), "example of text 2"),
tabItem(tabName = "uci_iden", titlePanel("example 2"), "example of text 3")
))
ui <- dashboardPage(dashboardHeader(title = "Indic", titleWidth = 285),
sidebar,
body)
server <- function(input, output) {
make_menus <- reactive({
if (req(input$tabs) %in% c("identificacion", "admision_iden", "uci_iden")) {
fluidRow(column(1),
column(
10,
menuItem(
"c1",
tabName = "admision_iden",
icon = icon("chart-line"),
selected = FALSE
),
menuItem(
"c8",
tabName = "uci_iden",
icon = icon("chart-line"),
selected = FALSE
)
))
} else {
div()
}
})
output$more_menus <- renderUI({ make_menus() })
}
runApp(list(ui = ui, server = server))

Resources