Loading shiny module only when menu items is clicked - r

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.

Related

Shiny Dashboard - Change Dashboard Body Based on Selected Tab

right now when the user runs the app, the desired website/dashboard body is displayed, however, I want the desired website/body to display ONLY when the user selects "Control Chart" from "Tab 1" in the sidebar menu. This is because I will have multiple sidebar tabs, when depending on the website the user selects, the embedded website should automatically change. When the user initially runs the app, the dashboard body should be blank. Only when they select Tab 1 -> Cell Culture -> Control Chart should they see the google homepage.
Please help!
ui <-
dashboardPage(
skin = "black",
dashboardHeader(title = "Dashboard ", titleWidth = 450),
dashboardSidebar(sidebarMenu(
menuItem(
"Tab 1",
tabName = "tab 1",
icon = icon("medicine"),
menuItem("Cell Culture",
menuItem("Control Chart"))
)
)),
dashboardBody(mainPanel(fluidRow(htmlOutput("frame"))
),
))
server = function(input, output, session) {
observe({
test <<- paste0("https://google.com") #sample url
})
output$frame <- renderUI({
input$Member
my_test <- tags$iframe(src = test,
height = 800,
width = 800)
print(my_test)
my_test
})
}
shinyApp(ui, server)
You can define a blank tab as the first menuItem, and then you should be able to select the appropriate menuItem to display the desired objects. Also, you should define tabName to ensure that the appropriate objects are displayed and tie it to them in dashboardBody as shown below. Try this
ui <-
dashboardPage(
skin = "black",
dashboardHeader(title = "Dashboard ", titleWidth = 450),
dashboardSidebar(sidebarMenu(
menuItem("",tabName="home"),
menuItem(
"Tab 1",
tabName = "tab 1",
icon = icon("medicine"),
menuItem("Cell Culture",
menuItem("Control Chart", tabName = "mytab"))
)
)),
dashboardBody(mainPanel(
tabItems(
tabItem(tabName = "home"),
tabItem(tabName = "mytab",
fluidRow(plotOutput("plot1"), htmlOutput("frame"))
)
)
),
))
server = function(input, output, session) {
#observe({
# test <- paste0("https://google.com") #sample url
#})
output$plot1 <- renderPlot(plot(cars))
url <- a("Google Homepage", href="https://www.google.com/")
output$frame <- renderUI({
#input$Member
my_test <- tags$iframe(href = url,
height = 800,
width = 800)
print(my_test)
print("Hello!")
my_test
})
}
shinyApp(ui, server)

Open modal on menuItem click

I would like to greet the user of my app with a modal once they click on a specific menuItem in the sidebar of my ShinyDashboard. Here's a simple recreation of my previous attempt:
# libraries
library(shiny)
library(shinydashboard)
## UI ##
ui <- dashboardPage(
skin = "black",
dashboardHeader(),
dashboardSidebar(
sidebarMenu(id = "sidebarmenu",
menuItem("Dashboard", tabName = "dashboard"),
menuItem("Subitems", tabName = "subitems",
menuSubItem("Upload", "upload"),
menuSubItem("Browse", "browse")
),
menuItem("Widgets", tabName = "widgets")
)
),
dashboardBody(
uiOutput('tab')
)
)
## server ##
server <- function(input, output) {
output$tab <- renderUI({
paste("The selected tab is", input$sidebarmenu)
})
observeEvent(input$sidebarmenu == "widgets", {
showModal(
modalDialog(title = "You selected Widgets", "Or did you?")
)
})
}
shinyApp(ui, server)
The goal is to open the modal only when the menuItem widgets is selected. Despite the condition input$sidebarmenu == "widgets", this does not happen. Rather, the modal is displayed any time the user switches menuItems. Why is this the case and how can I do this properly?
Thank you in advance for any input.
Add this to the observeEvent
observeEvent(input$sidebarmenu, {
req(input$sidebarmenu == "widgets")
showModal(
modalDialog(title = "You selected Widgets", "Or did you?")
)
})

Call updateTabItems from inside Shiny module

In my shiny app I have lots of valueBoxes, each representing a tabItem in the sidebar of the shinydashboard. When clicking on the valueBox the page should move to the correct tab.
Instead of copypasting the code lots of times I wrote a reusable module which renders the valueBox and changes the class of the valueBox into an actionButton. In the server part I have included an observeEvent which calls updateTabItems when the valueBox is clicked. But when clicked nothing happens. It seems that the module cannot manipulate the dashboard sidebar.
library(shiny)
library(shinydashboard)
value_box_output <- function(.id) {
ns <- NS(.id)
valueBoxOutput(ns("overview.box"))
}
value_box <- function(input, output, session, .value, .subtitle, .tab.name) {
ns <- session$ns
output$overview.box <- renderValueBox({
box1 <- valueBox(
.value,
.subtitle,
href = "#",
width = NULL
)
box1$children[[1]]$attribs$class <- "action-button"
box1$children[[1]]$attribs$id <- ns("button")
box1
})
observeEvent(input$button, {
print("clicked")
updateTabItems(session, inputId = "tabs", selected = .tab.name)
})
}
ui <- dashboardPage(
dashboardHeader(title = "Title"),
dashboardSidebar(
sidebarMenu(
id = "tabs",
menuItem("Overview", tabName = "Overview"),
menuItem("Tab 1", tabName = "Tab_1")
)
),
dashboardBody(
tabItems(
tabItem("Overview", value_box_output("tab")),
tabItem("Tab_1")
)
)
)
server <- function(input, output, session) {
callModule(value_box,
"tab",
.value = 33,
.subtitle = "Tab 1",
.tab.name = "Tab_1")
}
shinyApp(ui, server)
You can find the answer in this post: Accessing parent namespace inside a shiny module
Basically, in updateTabItems() inside a moulde, you need to call the parent's session, not the session of the modul.
Thus, add a variable for your session to callModule() and call it in updateTabItems().

Shinydashboard - Change background based on selected tab

I am creating a dashboard using Shinydashboard package, where I need to change the background color based on the selected Tab. I have tried the following code, but it is not working as intended.
library(shiny)
library(shinydashboard)
library(dplyr)
ui <- dashboardPage(dashboardHeader(dropdownMenuOutput("notificationMenu")),
dashboardSidebar(sidebarMenu(menuItem("Page 1", tabName = "page1"),
menuItem("Page 2", tabName = "page2"))),
dashboardBody(tags$style(".content {background-color: #f7f7f7;
.content-wrapper .tab-pane .shiny-tab-page1 {background-color: #000000;
}
"),
tabItems(
tabItem(tabName = "page1", h4("This is Page 1")),
tabItem(tabName = "page2",
textInput("text", "Enter News:", "New News."),
actionButton("save", "Save")))))
server <- function(input, output, session){
raw_news <- reactiveValues()
# Intial Header News: 1 Message from Admin
raw_news$news <- data_frame(from = "Admin", text = "this is a message")
# The notifications in header
output$notificationMenu <- renderMenu({
raw_news <- raw_news$news
dropdownMenu(
messageItem(raw_news$from[1], raw_news$text[1])
)
})
# save a new notification
observeEvent(input$save, {
raw_news$news <- data.frame(from = "User", text = input$text)
})
}
shinyApp(ui = ui, server = server)
Any help will be appreciated.
One possible solution would be to render a style tag, dependent on the selected tab. Note that in order to do so, the sidebarmenu needs an id. Below is a working example, hope this helps!
library(shiny)
library(shinydashboard)
ui <- dashboardPage(dashboardHeader(dropdownMenuOutput("notificationMenu")),
dashboardSidebar(sidebarMenu(id='sidebar',
menuItem("Page 1", tabName = "page1"),
menuItem("Page 2", tabName = "page2")),
uiOutput('style_tag')),
dashboardBody(
tabItems(
tabItem(tabName = "page1", h4("Blue!",style='color:white')),
tabItem(tabName = "page2", h4('Red!'))
))
)
server <- function(input, output, session){
output$style_tag <- renderUI({
if(input$sidebar=='page1')
return(tags$head(tags$style(HTML('.content-wrapper {background-color:blue;}'))))
if(input$sidebar=='page2')
return(tags$head(tags$style(HTML('.content-wrapper {background-color:red;}'))))
})
}
shinyApp(ui = ui, server = server)

Dynamic sidebar menu RShiny

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

Resources