I have a problem with my dashboard.
I want create a dynamic sidebar menu, but by default, Menu item don't work. The user has to clic on it to show it. I have find an example on this problem
https://github.com/rstudio/shinydashboard/issues/71
but the solution don't work.
If you have ideas... thank you in advance
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(
sidebarMenuOutput("menu")
),
dashboardBody(tabItems(
tabItem(tabName = "dashboard", h2("Dashboard tab content"))
))
)
server <- function(input, output) {
output$menu <- renderMenu({
sidebarMenu(id="mytabs",
menuItem("Menu item", tabName="dashboard", icon = icon("calendar"))
)
})
}
shinyApp(ui, server)
Here is a solution using updateTabItems.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(
sidebarMenu(id="mytabs",
sidebarMenuOutput("menu")
)
),
dashboardBody(tabItems(
tabItem(tabName = "dashboard", h2("Dashboard tab content"))
))
)
server <- function(input, output, session) {
output$menu <- renderMenu({
sidebarMenu(
menuItem("Menu item", tabName="dashboard", icon = icon("calendar"))
)
})
isolate({updateTabItems(session, "mytabs", "dashboard")})
}
shinyApp(ui, server)
To extend to dynamic menu you can see this exemple.
R shinydashboard dynamic menu selection
Edit : I think the isolate is not needed but I like to put it in a way to improve the reading of the code
Related
I cannot use updateTabItems() on a menuSubItem created by renderMenu() when I click on actionButton().
To illustrate my problem, here is an example code and a video (end of the post):
library(shiny)
library(DT)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
id = "tabs",
menuItem("First item", "first_item",
actionButton("action_button", "Action"),
menuSubItem("First sub item", "first_sub_item")
),
menuItem("Second item", "second_item",
menuItemOutput("second_sub_item")
)
)
),
dashboardBody(
tabItems(
tabItem("first_sub_item",
DT::dataTableOutput("df")
),
tabItem("second_sub_item",
verbatimTextOutput('row_selected')
)
)
)
)
server <- function(input, output, session){
observeEvent(input$action_button, {
output$df <- DT::renderDataTable(
as.data.frame(replicate(10,sample(0:1,1000,rep=TRUE)))
)
})
observeEvent(input$df_rows_selected, {
output$second_sub_item <- renderMenu({
menuSubItem("Second sub item", tabName = "second_sub_item")
})
updateTabItems(session, "tabs", "second_sub_item")
output$row_selected = renderPrint({
input$df_rows_selected
})
})
}
shinyApp(ui, server)
After clicking on a row of the df localised in the "first_sub_item", the ShinyApp should switch to the "second_sub_item", but it's doesn't work directly.
I have to click once by myself on the "second_sub_item" tab for the updateTabItems() function to work.
When "second_sub_item" is created in the UI, everything works, so the problem seems to come from renderMenu() but I can't solve it...
Thank you in advance for your help!
https://youtu.be/ZZmtN31chiA
I changed menuItemOutput to menuSubItem in your UI. Since it now already exists you don't need to render it again. When you now click on a row it will jump straight to your second menu item. Does this solve your problem?
library(shiny)
library(DT)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
id = "tabs",
menuItem("First item", "first_item",
actionButton("action_button", "Action"),
menuSubItem("First sub item", "first_sub_item")
),
menuItem("Second item", "second_item",
menuSubItem("Second sub item", "second_sub_item") #change to menuSubItem
)
)
),
dashboardBody(
tabItems(
tabItem("first_sub_item",
DT::dataTableOutput("df")
),
tabItem("second_sub_item",
verbatimTextOutput('row_selected')
)
)
)
)
server <- function(input, output, session){
observeEvent(input$action_button, {
output$df <- DT::renderDataTable(
as.data.frame(replicate(10,sample(0:1,1000,rep=TRUE)))
)
})
observeEvent(input$df_rows_selected, {
#Remove rendering of menuSubItem
updateTabItems(session, "tabs", "second_sub_item")
})
output$row_selected = renderPrint({
input$df_rows_selected
})
}
shinyApp(ui, server)
I am creating a sidebar menu from the Server of my Shiny app, but the formatting of the server-generated menu doesn't match with the menu created in the UI.
I have tried some shinyjs hide/show functions after assigning a div() to the menu which also ends up with an odd, non-matching format. I think renderMenu is probably the better path. I would prefer not to 'hack' with CSS, but any help is appreciated.
Here's a working script:
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = 'Header'),
dashboardSidebar(
sidebarMenu(
menuItem('First Menu', tabName = 'first_menu'),
menuSubItem('sub1', tabName = 'sub_1'),
menuSubItem('sub2', tabName = 'sub_2'),
uiOutput('server_menu')
)
),
dashboardBody()
)
server <- function(input, output) {
output$server_menu <- renderMenu({
list(
menuItem('Second Menu', tabName = 'second_menu'),
menuSubItem('sub3', tabName = 'sub_3'),
menuSubItem('sub4', tabName = 'sub_4')
)
})
}
shinyApp(ui, server)
Which produces this result:
Any advice on how I can solve this would be awesome! Cheers
Instead of uiOutput, use menuItemOutput. Also, your hierarchy of menuItem and menuSubItem seems to be incorrect. menuSubItem should be child of menuItem
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = 'Header'),
dashboardSidebar(
sidebarMenu(
menuItem(
'First Menu',
tabName = 'first_menu',
menuSubItem('sub1', tabName = 'sub_1'),
menuSubItem('sub2', tabName = 'sub_2')
),
menuItemOutput('server_menu') # Changed from uiOuput to menuItemOutput
)
),
dashboardBody()
)
server <- function(input, output) {
output$server_menu <- renderMenu({
list(
# modified hierarchies
menuItem(
'Second Menu',
tabName = 'second_menu',
menuSubItem('sub3', tabName = 'sub_3'),
menuSubItem('sub4', tabName = 'sub_4')
)
)
})
}
shinyApp(ui, server)
Background
Within a modular1 Shiny application, I would like to load module only when menu item on shinydashboard is clicked. If the menu item is not accessed I wouldn't like to load the module.
Basic application
app.R
# Libs
library(shiny)
library(shinydashboard)
# Source module
source("sample_module.R")
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(sidebarMenuOutput("menu")),
dashboardBody(tabItems(
tabItem(tabName = "tab_one", h1("Tab One")),
tabItem(tabName = "tab_two", sampleModuleUI("sampleModule"))
))
)
server <- function(input, output) {
callModule(sampleModuleServer, "sampleModule")
output$menu <- renderMenu({
sidebarMenu(
menuItem(
"Menu item 1",
icon = icon("calendar"),
tabName = "tab_one"
),
menuItem(
"Menu item 2",
icon = icon("globe"),
tabName = "tab_two"
)
)
})
}
shinyApp(ui, server)
sample_module.R
sampleModuleServer <- function(input, output, session) {
output$plot1 <- renderPlot({
plot(mtcars)
})
}
sampleModuleUI <- function(id) {
ns <- NS(id)
plotOutput(ns("plot1"))
}
Desired implementation
The desired implementation would load sample_module only when the relevant menu item is clicked. On the lines of 2:
Don't call callModule from inside observeEvent; keep it at the top level. Take the reactive expression that's returned, and use eventReactive to wrap it in the button click. And use the eventReactive from your outputs, etc.
x <- callModule(...)
y <- eventReactive(input$go, x())
output$tbl <- DT::renderDataTable(y())
Attempt
app.R (modified)
# Libs
library(shiny)
library(shinydashboard)
# Source module
source("sample_module.R")
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(sidebarMenuOutput("menu")),
dashboardBody(tabItems(
tabItem(tabName = "tab_one", h1("Tab One")),
tabItem(tabName = "tab_two", sampleModuleUI("sampleModule"))
))
)
server <- function(input, output) {
eventReactive(eventExpr = input$tab_two,
valueExpr = callModule(sampleModuleServer, "sampleModule")
)
output$menu <- renderMenu({
sidebarMenu(
menuItem(
"Menu item 1",
icon = icon("calendar"),
tabName = "tab_one"
),
menuItem(
"Menu item 2",
icon = icon("globe"),
tabName = "tab_two"
)
)
})
}
shinyApp(ui, server)
Problem
Application runs but the module does not load. Questions:
How to correctly call eventReactive on dashboard menu item? The tab_item does not seem to have id parameter is tabName equivalent in that context?
The linked discussion refers to refreshing one table. I'm trying to figure out example that will work with modules containing numerous interface element and elaborate server calls.
Clicking on Menu item 2 should display the content from the sample_module.R file.
1 Modularizing Shiny app code
2 Google groups: activate module with actionButton
Update
I've tried explicitly forcing module into application environment load using the following syntax:
eventReactive(eventExpr = input$tab_two,
valueExpr = callModule(sampleModuleServer, "sampleModule"),
domain = MainAppDomain
)
where
MainAppDomain <- getDefaultReactiveDomain()
Edit: Dropping Joe Cheng's top level statement:
# Libs
library(shiny)
library(shinydashboard)
# Source module
source("sample_module.R")
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(sidebarMenuOutput("menu")),
dashboardBody(tabItems(
tabItem(tabName = "tab_one", h1("Tab One")),
tabItem(tabName = "tab_two", sampleModuleUI("sampleModule"))
))
)
server <- function(input, output) {
observeEvent(input$tabs,{
if(input$tabs=="tab_two"){
callModule(sampleModuleServer, "sampleModule")
}
}, ignoreNULL = TRUE, ignoreInit = TRUE)
output$menu <- renderMenu({
sidebarMenu(id = "tabs",
menuItem(
"Menu item 1",
icon = icon("calendar"),
tabName = "tab_one"
),
menuItem(
"Menu item 2",
icon = icon("globe"),
tabName = "tab_two"
)
)
})
}
shinyApp(ui, server)
Furthermore, your sidebarMenu needs an id to access the selected tabs; please see the shinydashboard documentation.
I am trying to render shinydashboard after login page but shinydashboard skin color is not showing.
my code is as follow:
ui.r
library(shinydashboard)
library(shiny)
uiOutput("page")
Login.R
library(shinydashboard)
ui1Output <- function(id, label = "ui1") {
shinyUI(fluidPage(
mainPanel(
textInput("username","Username",placeholder ="UserName"),
passwordInput("password","Password", placeholder ="Password"),
actionButton("login", "Login")
)))
}
dashbaordpage.R
library(shinydashboard)
dashpageOutput <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Widgets", tabName = "widgets", icon = icon("th"))
)
),
dashboardBody(
tabItems(
# First tab content
tabItem(tabName = "dashboard",h2("Dashbaord")),
# Second tab content
tabItem(tabName = "widgets",
h2("Widgets tab content")
)
)
)
global.R
source('login.R') #login page
source('dashboardPage.R')#dashbaordpage
server.R
library(shiny)
library(shinydashboard)
shinyServer(function(input, output,session) {
output$page <- renderUI({
ui1Output('ui1Output')
})
observeEvent(input$login,
{
if(True)
{
output$page <- renderUI(dashpageOutput)
}
else
{
Logged<-F
showModal(modalDialog(
title = "Error",
"Enter Correct Username and password"
))
}
})
})
Details: when I going dashboard is showing but not with default skin color or any other skin color. I have tried skin='red' like wise option.
Image for reference how actually showing after login.
Please help me.
Thanks in advance.
I have 3 selectInput boxes and a pool of 4 options which can be selected by these 3 boxes. I want the options displayed by the selectInputs to change dynamically as other selectInputs are selected. However I want the "NONE" option to be available at all points of time for all the three boxes. The code I am using is
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic selectInput"),
dashboardSidebar(
sidebarMenu(
menuItemOutput("menuitem")
)
),
dashboardBody(
uiOutput('heirarchy1'),
uiOutput('heirarchy2'),
uiOutput('heirarchy3')
)
)
server <- function(input, output) {
output$menuitem <- renderMenu({
menuItem("Menu item", icon = icon("calendar"))
})
heirarchy_vector<-c("NONE","A","B","C")
output$heirarchy1<-renderUI({
selectInput("heir1","Heirarchy1",c("NONE",setdiff(heirarchy_vector,c(input$heir2,input$heir3))),selected="NONE")
})
output$heirarchy2<-renderUI({
selectInput("heir2","Heirarchy2",c("NONE",setdiff(heirarchy_vector,c(input$heir1,input$heir3))),selected="NONE")
})
output$heirarchy3<-renderUI({
selectInput("heir3","Heirarchy3",c("NONE",setdiff(heirarchy_vector,c(input$heir1,input$heir2))),selected="NONE")
})
}
shinyApp(ui, server)
Any help on this will be greatly appreciated
EDIT
I tried using updateSelectInput for this purpose. However the code doesn't seem to run
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic selectInput"),
dashboardSidebar(
sidebarMenu(
menuItemOutput("menuitem")
)
),
dashboardBody(
selectInput("heir1","Heirarchy1",c("NONE","A","B","C"),selected="NONE"),
selectInput("heir2","Heirarchy2",c("NONE","A","B","C"),selected="NONE"),
selectInput("heir3","Heirarchy3",c("NONE","A","B","C"),selected="NONE")
)
)
server <- function(input, output) {
output$menuitem <- renderMenu({
menuItem("Menu item", icon = icon("calendar"))
})
heirarchy<-c("A","B","C")
observe({
hei1<-input$heir1
hei2<-input$heir2
hei3<-input$heir3
choice1<-c("NONE",setdiff(heirarchy,c(hei2,hei3)))
choice2<-c("NONE",setdiff(heirarchy,c(hei1,hei3)))
choice3<-c("NONE",setdiff(heirarchy,c(hei1,hei2)))
updateSelectInput(session,"heir1",choices=choice1)
updateSelectInput(session,"heir2",choices=choice2)
updateSelectInput(session,"heir3",choices=choice3)
})
}
shinyApp(ui, server)
You're close! Two things, you need to assign the session variable when you start your server instance, also when you update the select inputs you need to set which choice was selected, other than that everything looks OK. Try this:
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic selectInput"),
dashboardSidebar(
sidebarMenu(
menuItemOutput("menuitem")
)
),
dashboardBody(
selectInput("heir1","Heirarchy1",c("NONE","A","B","C"),selected="NONE"),
selectInput("heir2","Heirarchy2",c("NONE","A","B","C"),selected="NONE"),
selectInput("heir3","Heirarchy3",c("NONE","A","B","C"),selected="NONE")
)
)
server <- function(input, output, session) {
output$menuitem <- renderMenu({
menuItem("Menu item", icon = icon("calendar"))
})
heirarchy<-c("A","B","C")
observe({
hei1<-input$heir1
hei2<-input$heir2
hei3<-input$heir3
choice1<-c("NONE",setdiff(heirarchy,c(hei2,hei3)))
choice2<-c("NONE",setdiff(heirarchy,c(hei1,hei3)))
choice3<-c("NONE",setdiff(heirarchy,c(hei1,hei2)))
updateSelectInput(session,"heir1",choices=choice1,selected=hei1)
updateSelectInput(session,"heir2",choices=choice2,selected=hei2)
updateSelectInput(session,"heir3",choices=choice3,selected=hei3)
})
}
shinyApp(ui, server)