For the code below, I would like to have a menu (dashboardSidebar) that collapses when any menuItem but item2 is clicked.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(collapsed = TRUE, sidebarMenu(id = "tabs",
menuItem("item1", tabName = "item1", icon = icon("newspaper")),
menuItem("item2", tabName = "item2", icon = icon("tv"),
menuItem("item2_1", tabName = "item2_1", icon = icon("tasks")),
menuItem("item2_2", tabName = "item2_2", icon = icon("flag-checkered")),
menuItem("item2_3", tabName = "item2_3", icon = icon("user-clock"))))),
dashboardBody())
server <- function(input, output) {}
shinyApp(ui, server)
Thanks
Please check the following:
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(collapsed = TRUE, sidebarMenu(
id = "tabs",
menuItem("item1", tabName = "item1", icon = icon("newspaper")),
menuItem(
"item2",
tabName = "item2",
icon = icon("tv"),
menuItem("item2_1", tabName = "item2_1", icon = icon("tasks")),
menuItem(
"item2_2",
tabName = "item2_2",
icon = icon("flag-checkered")
),
menuItem("item2_3", tabName = "item2_3", icon = icon("user-clock"))
)
)),
dashboardBody(useShinyjs(),
tabItems(
tabItem(tabName = "item1",
h2("item1 tab content")),
tabItem(tabName = "item2_1",
h2("item2_1 tab content")),
tabItem(tabName = "item2_2",
h2("item2_2 tab content")),
tabItem(tabName = "item2_3",
h2("item2_3 tab content"))
))
)
server <- function(input, output, session) {
observeEvent(input$tabs, {
shinyjs::toggleClass(selector = "body", class = "sidebar-collapse")
}, ignoreInit = TRUE)
}
shinyApp(ui, server)
The only drawback is, that selecting the same menuItem twice doesn't collapse the sidebar, due to input$tabs remaining unchanged.
Related
Suppose you have a simple shinydashboard which contains links created with menuItem and pages created with tabItems:
library(shiny)
library(shinydashboard)
skin <- Sys.getenv("DASHBOARD_SKIN")
skin <- tolower(skin)
skin <- "blue"
## ui.R ##
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Widgets", icon = icon("th"), tabName = "widgets",
badgeLabel = "new", badgeColor = "green")
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content")
),
tabItem(tabName = "widgets",
h2("Widgets tab content")
)
)
)
# Put them together into a dashboardPage
ui<-dashboardPage(
dashboardHeader(title = "Simple tabs"),
sidebar,
body
)
server <- function(input, output) {
}
shinyApp(ui, server)
Is it possible to create permalinks for the pages? e.g. the home page (tabName == "dashboard") has a URL of 127.0.0.1:1234/home and the widgets page is at 127.0.0.1:1234/widgets?
It seems that shiny doesn't have URL routing out of the box. shiny.router seems to be a possible alternative but I've found no easy ways to do this with shinydashboard i.e. with the use of menuItem and tabItem. I'm trying to avoid rewriting the app's UI to use something which is more tightly integrated with shiny.router (e.g. shiny.semantic)
Is it possible to keep the above shinydashboard code while implementing permalinks to the various different pages?
Here is how to use the below approach with shiny's tabPanel() function.
Workarounds not using library(shiny.router):
Edit - Alternative using clientData$url_search and mode = "push" for updateQueryString to push a new history entry onto the browser's history stack:
library(shiny)
library(shinydashboard)
ui <- function(request) {
dashboardPage(
header = dashboardHeader(title = "Simple tabs"),
sidebar = dashboardSidebar(
sidebarMenu(
id = "sidebarID",
menuItem(
"Dashboard",
tabName = "dashboard",
icon = icon("tachometer-alt")
),
menuItem(
"Widgets",
icon = icon("th"),
tabName = "widgets",
badgeLabel = "new",
badgeColor = "green"
)
)
),
body = dashboardBody(tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content")),
tabItem(tabName = "widgets",
h2("Widgets tab content"))
))
)
}
server <- function(input, output, session) {
# http://127.0.0.1:6172/?tab=dashboard
# http://127.0.0.1:6172/?tab=widgets
observeEvent(getQueryString(session)$tab, {
currentQueryString <- getQueryString(session)$tab # alternative: parseQueryString(session$clientData$url_search)$tab
if(is.null(input$sidebarID) || !is.null(currentQueryString) && currentQueryString != input$sidebarID){
freezeReactiveValue(input, "sidebarID")
updateTabItems(session, "sidebarID", selected = currentQueryString)
}
}, priority = 1)
observeEvent(input$sidebarID, {
currentQueryString <- getQueryString(session)$tab # alternative: parseQueryString(session$clientData$url_search)$tab
pushQueryString <- paste0("?tab=", input$sidebarID)
if(is.null(currentQueryString) || currentQueryString != input$sidebarID){
freezeReactiveValue(input, "sidebarID")
updateQueryString(pushQueryString, mode = "push", session)
}
}, priority = 0)
}
shinyApp(ui, server, enableBookmarking = "disable")
Another Edit - using url_hash (uri fragments):
library(shiny)
library(shinydashboard)
ui <- function(request) {
dashboardPage(
header = dashboardHeader(title = "Simple tabs"),
sidebar = dashboardSidebar(
sidebarMenu(
id = "sidebarID",
menuItem(
"Dashboard",
tabName = "dashboard",
icon = icon("tachometer-alt")
),
menuItem(
"Widgets",
icon = icon("th"),
tabName = "widgets",
badgeLabel = "new",
badgeColor = "green"
)
)
),
body = dashboardBody(tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content")),
tabItem(tabName = "widgets",
h2("Widgets tab content"))
))
)
}
server <- function(input, output, session) {
observeEvent(input$sidebarID, {
# http://127.0.0.1:6172/#dashboard
# http://127.0.0.1:6172/#widgets
newURL <- paste0(
session$clientData$url_protocol,
"//",
session$clientData$url_hostname,
":",
session$clientData$url_port,
session$clientData$url_pathname,
"#",
input$sidebarID
)
updateQueryString(newURL, mode = "replace", session)
})
observe({
currentTab <- sub("#", "", session$clientData$url_hash)
if(!is.null(currentTab)){
updateTabItems(session, "sidebarID", selected = currentTab)
}
})
}
shinyApp(ui, server, enableBookmarking = "disable")
Edit - using url_search: Actually we can do the same without bookmarking using getQueryString and updateTabItems:
library(shiny)
library(shinydashboard)
ui <- function(request) {
dashboardPage(
header = dashboardHeader(title = "Simple tabs"),
sidebar = dashboardSidebar(
sidebarMenu(
id = "sidebarID",
menuItem(
"Dashboard",
tabName = "dashboard",
icon = icon("tachometer-alt")
),
menuItem(
"Widgets",
icon = icon("th"),
tabName = "widgets",
badgeLabel = "new",
badgeColor = "green"
)
)
),
body = dashboardBody(tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content")),
tabItem(tabName = "widgets",
h2("Widgets tab content"))
))
)
}
server <- function(input, output, session) {
observeEvent(input$sidebarID, {
# http://127.0.0.1:6172/?tab=dashboard
# http://127.0.0.1:6172/?tab=widgets
newURL <- paste0(
session$clientData$url_protocol,
"//",
session$clientData$url_hostname,
":",
session$clientData$url_port,
session$clientData$url_pathname,
"?tab=",
input$sidebarID
)
updateQueryString(newURL, mode = "replace", session)
})
observe({
currentTab <- getQueryString(session)$tab # alternative: parseQueryString(session$clientData$url_search)$tab
if(!is.null(currentTab)){
updateTabItems(session, "sidebarID", selected = currentTab)
}
})
}
shinyApp(ui, server, enableBookmarking = "disable")
Using bookmarks:
Not sure if you are interested in a workaround like this, but you could use shiny's bookmarking and updateQueryString to achive a similar behaviour:
library(shiny)
library(shinydashboard)
ui <- function(request) {
dashboardPage(
header = dashboardHeader(title = "Simple tabs"),
sidebar = dashboardSidebar(
sidebarMenu(
id = "sidebarID",
menuItem(
"Dashboard",
tabName = "dashboard",
icon = icon("tachometer-alt")
),
menuItem(
"Widgets",
icon = icon("th"),
tabName = "widgets",
badgeLabel = "new",
badgeColor = "green"
)
)
),
body = dashboardBody(tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content")),
tabItem(tabName = "widgets",
h2("Widgets tab content"))
))
)
}
server <- function(input, output, session) {
bookmarkingWhitelist <- c("sidebarID")
observe({
setBookmarkExclude(setdiff(names(input), bookmarkingWhitelist))
})
observeEvent(input$sidebarID, {
# http://127.0.0.1:6172/?_inputs_&sidebarID=%22dashboard%22
# http://127.0.0.1:6172/?_inputs_&sidebarID=%22widgets%22
newURL <- paste0(
session$clientData$url_protocol,
"//",
session$clientData$url_hostname,
":",
session$clientData$url_port,
session$clientData$url_pathname,
"?_inputs_&sidebarID=%22",
input$sidebarID,
"%22"
)
updateQueryString(newURL,
mode = "replace",
session)
})
}
shinyApp(ui, server, enableBookmarking = "url")
Some related links:
https://rstudio.github.io/shinydashboard/behavior.html#bookmarking
https://shiny.rstudio.com/reference/shiny/1.7.0/session.html
It is possible to restore a session, locally, in a Shiny app if the inputs have been previously written in a RDS file?
shinyjs - setBookmarkExclude for delay IDs
https://github.com/rstudio/shiny/issues/3546
When clicking on a menu item in the side bar I would like it to not only expand and show the menu sub items but also preselect the first one and show the corresponding tab item UI.
I know it is possible to define one item as selected and it will show when I start the app. To me this is confusing behaviour because the corresponding menu item does not appear as "selected" in the sidebar. My requirement goes further anyway since I want to preselect a menu sub item every time I click on a menu item.
library(shinydashboard)
library(shiny)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItem("Table1" , tabname = "my_table1", icon = icon("table"),startExpanded = F,
menuSubItem("sub menu1",tabName = "subMenu1"),
menuSubItem("sub menu2",tabName = "subMenu2")
),
menuItem("Table2" , tabname = "my_table2", icon = icon("table"),startExpanded = F,
menuSubItem("sub menu3",tabName = "subMenu3"),
menuSubItem("sub menu4",tabName = "subMenu4", selected = T)
)
)),
dashboardBody(
tabItems(
tabItem(tabName = "my_table1",
h2("First Table")
),
tabItem(tabName = "my_table2",
h2("Second Table")
),
tabItem(tabName = "subMenu1",
h2("First tab")
),
tabItem(tabName = "subMenu2",
h2("Second tab")
),
tabItem(tabName = "subMenu3",
h2("Third tab")
),
tabItem(tabName = "subMenu4",
h2("Fourth tab")
)
)))
server <- function(input, output) {
}
shinyApp(ui, server)
Your sidebarMenu needs an id and your server function needs the session argument, so you can use:
updateTabItems(session, inputId="sidebarID", selected="subMenu1")
Please check the following:
library(shinydashboard)
library(shiny)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
id = "sidebarID",
menuItem("Table1" , tabname = "my_table1", icon = icon("table"), startExpanded = TRUE,
menuSubItem("sub menu1",tabName = "subMenu1", selected = TRUE),
menuSubItem("sub menu2",tabName = "subMenu2")
),
menuItem("Table2" , tabname = "my_table2", icon = icon("table"), startExpanded = FALSE,
menuSubItem("sub menu3",tabName = "subMenu3"),
menuSubItem("sub menu4",tabName = "subMenu4")
)
)),
dashboardBody(
tabItems(
tabItem(tabName = "my_table1",
h2("First Table")
),
tabItem(tabName = "my_table2",
h2("Second Table")
),
tabItem(tabName = "subMenu1",
h2("First tab")
),
tabItem(tabName = "subMenu2",
h2("Second tab")
),
tabItem(tabName = "subMenu3",
h2("Third tab")
),
tabItem(tabName = "subMenu4",
h2("Fourth tab")
)
)))
server <- function(input, output, session) {
observeEvent(input$sidebarItemExpanded, {
cat(paste("menuItem() currently expanded:", input$sidebarItemExpanded, "\n"))
if(input$sidebarItemExpanded == "Table1"){
updateTabItems(session, inputId="sidebarID", selected="subMenu1")
} else if(input$sidebarItemExpanded == "Table2"){
updateTabItems(session, inputId="sidebarID", selected="subMenu3")
}
})
observe({
cat(paste("tabItem() currently selected:", input$sidebarID, "\n"))
})
}
shinyApp(ui, server)
Furthermore please see the related docs.
I am trying to have an action button within the Body of a tab (called "Widgets" in code) link to a different tab (called "data_table" in code). I know how to do this if the tab that I want to connect to, "data_table", is one of the menuItems that appears on the sidebarMenu. However, I do not wish for a link to the "data_table" tab to appear in the sidebar. I am stuck. I would have thought I need an "observeEvent"-type command which links the action button to the "data_table" tab. But I don't know what that is. Advice welcome. The code shows the UI side of things.
ui <- dashboardPage(
dashboardHeader(title = "My query"),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Widgets", tabName = "widgets", icon = icon("th"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content")),
tabItem(tabName = "widgets",
h2("Widgets"),
actionButton(inputId="seedata", label = "See data")),
tabItem(tabName = "data_table",
h2("Table with the data"))
)
)
)
server <- function(input, output, session) { }
shinyApp(ui, server)
Perhaps you are looking for something like this.
ui <- dashboardPage(
dashboardHeader(title = "My query"),
dashboardSidebar(
sidebarMenu(# Setting id makes input$tabs give the tabName of currently-selected tab
id = "tabs",
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Widgets", tabName = "widgets", icon = icon("th"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content")),
tabItem(tabName = "widgets", h2("Widgets"),
fluidRow(
tabBox(id = "tabset1", height = "850px", width=12, title = "My Data",
### The id lets us use input$tabset1 on the server to find the current tab
tabPanel("Table with the data", value="tab1", " ",
actionButton(inputId="seedata", label = "See data"),
uiOutput("dataTable")
),
tabPanel("Display Data Table", value="tab2", " ",
#uiOutput("someoutput")
DT::dataTableOutput("testtable")
)
)
)
))
)
)
server <- function(input, output, session) {
output$dataTable <- renderUI({
tagList(
div(style="display: block; height: 350px; width: 5px;",HTML("<br>")),
actionBttn(inputId="datatable",
label="Data Table",
style = "simple",
color = "success",
size = "md",
block = FALSE,
no_outline = TRUE
))
})
observeEvent(input$datatable, {
updateTabItems(session, "tabs", "widgets")
if (input$datatable == 0){
return()
}else{
## perform other tasks if necessary
output$testtable <- DT::renderDataTable(
mtcars,
class = "display nowrap compact", # style
filter = "top", # location of column filters
options = list( # options
scrollX = TRUE # allow user to scroll wide tables horizontally
)
)
}
})
observeEvent(input$datatable, {
updateTabsetPanel(session, "tabset1",
selected = "tab2")
})
}
shinyApp(ui, server)
I found that menuSubItem content is not rendering in case of several (more than one) tabItems.
Minimal example demonstrating this behavior is below.
The desired behavior is to show content of the tabItem marked as selected = TRUE on startup. Now, the content shows up only after switching between menuSubItems in the sidebar.
How can I make it work?
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "MINIMAL EXAMPLE"),
dashboardSidebar(
sidebarMenuOutput("menu")
),
dashboardBody(
uiOutput("body")
)
)
server <- function(input, output, session) {
output$menu <- renderMenu(
sidebarMenu(
menuItem(text = "TABS", tabName = "TABS", startExpanded = T,
menuSubItem(text = "tab1", tabName="tab1",
icon = icon("cube"), selected = TRUE),
menuSubItem(text = "tab2", tabName="tab2",
icon = icon("cube"), selected = FALSE)
)
)
)
output$body <- renderUI({
tabItems(
tabItem(tabName = "tab1",
h4("MY TEXT 1")
),
tabItem(tabName = "tab2",
h4("MY TEXT 2")
))
})
}
shinyApp(ui = ui, server = server)
Indeed, putting ui elements directly in UI solves it.
But the approach of putting everything inside ui is limited to situations that do not involve using reactive values. As I understand passing reactive value from server to ui is not possible in general (or limited to special cases). Please correct if I am wrong... Thanks
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "MINIMAL EXAMPLE"),
dashboardSidebar(
sidebarMenuOutput("menu")
),
dashboardBody(
tabItems(
tabItem(tabName = "tab1",
h4("MY TEXT 1")
),
tabItem(tabName = "tab2",
h4("MY TEXT 2")
))
)
)
server <- function(input, output, session) {
output$menu <- renderMenu(
sidebarMenu(
menuItem(text = "TABS", tabName = "TABS", startExpanded = T,
menuSubItem(text = "tab1", tabName="tab1",
icon = icon("cube"), selected = TRUE),
menuSubItem(text = "tab2", tabName="tab2",
icon = icon("cube"), selected = FALSE)
)
)
)
}
shinyApp(ui = ui, server = server)
Renaming your output to something other than "body" helps - please see this.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "MINIMAL EXAMPLE"),
dashboardSidebar(
sidebarMenuOutput("menu")
),
dashboardBody(
uiOutput("myBodyOutput")
)
)
server <- function(input, output, session) {
output$myBodyOutput <- renderUI({
tabItems(
tabItem(tabName = "tab1",
h4("MY TEXT 1")
),
tabItem(tabName = "tab2",
h4("MY TEXT 2")
))
})
output$menu <- renderMenu(
sidebarMenu(id = "sidebarID",
menuItem(text = "TABS", tabName = "TABS", startExpanded = T,
menuSubItem(text = "tab1", tabName="tab1",
icon = icon("cube"), selected = TRUE),
menuSubItem(text = "tab2", tabName="tab2",
icon = icon("cube"), selected = FALSE)
)
)
)
}
shinyApp(ui = ui, server = server)
I need to render various menu sub-items based on some reactive data values. For each sub-item, I also need to associate linked output. I tried to link with tabName, but not sure what went wrong.
Below is an example. The desired output will be one box for each menu item/sub-item.
## This code snippet doesn't do what I need ----
shinyApp(
ui = dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItemOutput("dynamic_menu"),
menuItem("Menu2", tabName = "menu2")
)
),
dashboardBody(
tabItems(
uiOutput("menu1_content"),
tabItem(tabName = "menu2", box("I am menu2"))
)
),
title = "Example"
),
server = function(input, output) {
output$dynamic_menu <- renderMenu({
submenu_list <- lapply(letters[1:5], function(x) {
menuSubItem(x, tabName = paste0("menu1-", x))
})
menuItem(
text = "Menu1",
startExpanded = TRUE,
do.call(tagList, submenu_list)
)
})
output$menu1_content <- renderUI({
content_list <- lapply(letters[1:5], function(x) {
tabItem(
tabName = paste0("menu1-", x),
box(x)
)
})
do.call(tagList, content_list)
})
}
)
## This code snippet does what I need ----
shinyApp(
ui = dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItem(
"Menu1", startExpanded = TRUE,
menuSubItem("a", tabName = "menu1-a"),
menuSubItem("b", tabName = "menu1-b"),
menuSubItem("c", tabName = "menu1-c"),
menuSubItem("d", tabName = "menu1-d"),
menuSubItem("e", tabName = "menu1-e")
),
menuItem("Menu2", tabName = "menu2")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "menu1-a", box("a")),
tabItem(tabName = "menu1-b", box("b")),
tabItem(tabName = "menu1-c", box("c")),
tabItem(tabName = "menu1-d", box("d")),
tabItem(tabName = "menu1-e", box("e")),
tabItem(tabName = "menu2", box("I am menu2"))
),
title = "Example"
)
),
server = function(input, output) {}
)
Answering my own question, but feel free to jump in if you have something more elegant.
I think my initial understanding of shiny dashboard is wrong, causing the app structure to be invalid.
The trick here is to add id to the sidebarMenu, so that page focus could be tracked and parsed later. Then each of the render function will listen on the input and render associated content.
shinyApp(
ui = dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
id = "sidebar_menu",
menuItemOutput("dynamic_menu"),
menuItem("Menu2", tabName = "menu2")
)
),
dashboardBody(
uiOutput("menu1_content"),
uiOutput("menu2_content")
),
title = "Example"
),
server = function(input, output, session) {
output$dynamic_menu <- renderMenu({
menu_list <- lapply(letters[1:5], function(x) {
menuSubItem(x, tabName = paste0("menu1-", x))
})
menuItem(
text = "Menu1",
startExpanded = TRUE,
do.call(tagList, menu_list)
)
})
output$menu1_content <- renderUI({
sidebar_menu <- tstrsplit(input$sidebar_menu, "-")
if (sidebar_menu[[1]] == "menu1") box(sidebar_menu[[2]])
})
output$menu2_content <- renderUI({
sidebar_menu <- tstrsplit(input$sidebar_menu, "-")
if (sidebar_menu[[1]] == "menu2") box("I am menu2")
})
}
)