Call updateTabItems from inside Shiny module - r

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().

Related

Loading shiny module only when menu items is clicked

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.

scoping issue with updateNavbarPage() function from within shiny module

I am trying to build an app where the user is able to switch tabs when clicking on a specific object. However, I have developed the app using modules and would like to continue to do so. I am running into a problem with the scoping when trying to call the updateNavbarPage() function from inside of the modules. I have created a MWE example to illustrate the problem.
#==================================================
# MRE for updateNavBar scoping issue within modules
#==================================================
modOneUI <- function(id){
ns <- NS(id)
tagList(
h4(
"Click this button to change tabs!"
),
actionButton(
ns("submit"),
label = "Go to next Tab"
)
)
}
modOne <- function(input, output, session){
observeEvent(input$submit, {
updateNavbarPage(session, "nav-page", "tab2")
})
}
ui <- shinyUI(
navbarPage(
id = "nav-page",
title = "Example Navbar Page Issue",
tabPanel(
id = "tab1",
value = "tab1",
div(
"Tab 1"
),
div(
modOneUI("tab1_mod")
)
),
tabPanel(
id = "tab2",
value = "tab2",
div(
"Tab 2"
),
div(
h4("This is the second tab")
)
)
)
)
server <- shinyServer(function(input, output, session){
callModule(modOne, "tab1_mod")
})
shinyApp(ui = ui, server = server)
When this app is run, and the action button is clicked on the first tab, nothing happens. However if you remove the module and place the ui and server module code directly into the ui and server portions then clicking the button works. Here is the code with the modules removed.
ui <- shinyUI(
navbarPage(
id = "nav-page",
title = "Example Navbar Page Issue",
tabPanel(
id = "tab1",
value = "tab1",
div(
"Tab 1"
),
div(
h4(
"Click this button to change tabs!"
),
actionButton(
"submit",
label = "Go to next Tab"
)
)
),
tabPanel(
id = "tab2",
value = "tab2",
div(
"Tab 2"
),
div(
h4("This is the second tab")
)
)
)
)
server <- shinyServer(function(input, output, session){
observeEvent(input$submit, {
updateNavbarPage(session, "nav-page", "tab2")
})
})
shinyApp(ui = ui, server = server)
Is there any way to use updateNavbarPage() from within a module to switch to a tab that is in not in the module?
Do not ask me why :-) but it works like this:
modOne <- function(input, output, session, x){
observeEvent(input$submit, {
updateNavbarPage(x, "nav-page", "tab2")
})
}
callModule(modOne, "tab1_mod", x=session)

Shiny - Can dynamically generated buttons act as trigger for an event

I have a shiny code that generates actions buttons from a numericInput and each of those actions buttons generate a plot when clicked using a observeEvent. The problem is that I don't know how to trigger an event with dynamically generated buttons. The workaround I used was to make a observeEvent for each button but if I generate more buttons than the obserEvents I created it won't work.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic selectInput"),
dashboardSidebar(
sidebarMenu(
menuItemOutput("menuitem")
)
),
dashboardBody(
numericInput("go_btns_quant","Number of GO buttons",value = 1,min = 1,max = 10),
uiOutput("go_buttons"),
plotOutput("plot")
)
)
server <- function(input, output, session) {
output$menuitem <- renderMenu({
menuItem("Menu item", icon = icon("calendar"))
})
output$go_buttons <- renderUI({
buttons <- as.list(1:input$go_btns_quant)
buttons <- lapply(buttons, function(i)
fluidRow(
actionButton(paste0("go_btn",i),paste("Go",i))
)
)
})
#Can this observeEvents be triggerd dynamicly?
observeEvent(input[[paste0("go_btn",1)]],{output$plot <-renderPlot({hist(rnorm(100,4,1),breaks = 10)})})
observeEvent(input[[paste0("go_btn",2)]],{output$plot <- renderPlot({hist(rnorm(100,4,1),breaks = 50)})})
observeEvent(input[[paste0("go_btn",3)]],{output$plot <- renderPlot({hist(rnorm(100,4,1),breaks = 100)})})
observeEvent(input[[paste0("go_btn",4)]],{output$plot <- renderPlot({hist(rnorm(100,4,1),breaks = 200)})})
observeEvent(input[[paste0("go_btn",5)]],{output$plot <- renderPlot({hist(rnorm(100,4,1),breaks = 500)})})
}
shinyApp(ui, server)
You can also create observers dynamically. Just make sure that they are created only once, otherwise they will execute several times.
Below is your code modified to create as many observers as buttons. Please note that if an observer for the button already exist, it should not be created. You can customize your observers too, so each observer could have its own behavior.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic selectInput"),
dashboardSidebar(
sidebarMenu(
menuItemOutput("menuitem")
)
),
dashboardBody(
numericInput("go_btns_quant","Number of GO buttons",value = 1,min = 1,max = 10),
uiOutput("go_buttons"),
plotOutput("plot")
)
)
server <- function(input, output, session) {
output$menuitem <- renderMenu({
menuItem("Menu item", icon = icon("calendar"))
})
# to store observers and make sure only once is created per button
obsList <- list()
output$go_buttons <- renderUI({
buttons <- as.list(1:input$go_btns_quant)
buttons <- lapply(buttons, function(i)
{
btName <- paste0("go_btn",i)
# creates an observer only if it doesn't already exists
if (is.null(obsList[[btName]])) {
# make sure to use <<- to update global variable obsList
obsList[[btName]] <<- observeEvent(input[[btName]], {
cat("Button ", i, "\n")
output$plot <-renderPlot({hist(rnorm(100, 4, 1),breaks = 50*i)})
})
}
fluidRow(
actionButton(btName,paste("Go",i))
)
}
)
})
}

Shiny Dashboard - display a dedicated "loading.." page until initial loading of the data is done

I have initial loading of data from the DB in the server.R which takes a few seconds. Until this is done, the page displayed is distorted (wrong data in selection box, and weird placing of the boxes, see below).
I want to display a different page (or at least different content in my first-displayed tab) until the data is completely loaded.
I thought about doing some kind of conditionalPanel using a condition based on a dedicated global variable (initial_loading_done), but wherever I tried placing the conditionalPanel it didn't work.
This is the structure of my UI.R:
shinyUI(
dashboardPage(
dashboardHeader(title = "Title"),
dashboardSidebar(
sidebarMenu(
menuItem("Tab1", tabName = "Tab1",icon = icon("dashboard")),
menuItem("Tab2", tabName = "Tab2", icon = icon("bar-chart-o"))
)
),
dashboardBody(
includeCSS("custom_css.css"),
tabItems(
tabItem(tabName = "Tab1",
fluidRow(<content>),
mainPanel(
fluidRow(<content>)
)
),
tabItem(tabName = "Tab2",
fluidRow(<content>),
mainPanel(
dataTableOutput('my_data_table')
)
)
)
)
)
)
Here's a very simple example using shinyjs package
The idea is to create the loading "page" and the content "page" under different IDs, have the content page initially hidden, and use show() and hide() after the app is ready
library(shiny)
library(shinyjs)
load_data <- function() {
Sys.sleep(2)
hide("loading_page")
show("main_content")
}
ui <- fluidPage(
useShinyjs(),
div(
id = "loading_page",
h1("Loading...")
),
hidden(
div(
id = "main_content",
"Data loaded, content goes here"
)
)
)
server <- function(input, output, session) {
load_data()
}
shinyApp(ui = ui, server = server)
In server I like to use reactiveValues() to store a setupComplete condition. Then, when the data is loaded my setupComplete is set to TRUE.
In the ui we can then assess this setupComplete condition in a conditionalPanel, and only display the content (in my example the three box() widgets).
Here's a working example
## app.R ##
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
actionButton(inputId = "btn_data", label = "Download"),
conditionalPanel(condition = "output.setupComplete",
box( title = "box1" ),
box( title = "box2" ),
box( title = "boc3" )
),
conditionalPanel(condition = "!output.setupComplete",
box( title = "loading"))
)
)
server <- function(input, output) {
rv <- reactiveValues()
rv$setupComplete <- FALSE
## simulate data load
observe({
if(input$btn_data){
df <- data.frame(id = seq(1,200),
val = rnorm(200, 0, 1))
## Simulate the data load
Sys.sleep(5)
## set my condition to TRUE
rv$setupComplete <- TRUE
}
## the conditional panel reads this output
output$setupComplete <- reactive({
return(rv$setupComplete)
})
outputOptions(output, 'setupComplete', suspendWhenHidden=FALSE)
})
}
shinyApp(ui, server)
The code
hidden(
div(
id = "main_content",
"Data loaded, content goes here"
)
doesn't work with tabsetPanel. But if you move the id to the div level it works beautifully. Thanks to shinyjs author Dean Attali for this tip. https://stackoverflow.com/users/4432127/keshete
hidden(
div(id = "mainTabsetPanel",
tabsetPanel(
....

R Shinydashboard dynamic menuItem

I'm trying to generate multiple menuItems dynamically, may be simple, but I'm not getting the right idea.
library(shiny)
library(shinydashboard)
port_tables<-c("tab1","tab2","tab3","tab4") # These are from a DB connection in the original code
function(input, output) {
output$smenu1 <- renderMenu({
sidebarMenu( id = "tabs",
h4("Tables",style="color:yellow;margin-left:20px;"),
paste("menuItem(\"",port_tables,"\",tabName=\"",port_tables,"\",icon=icon('th'))",collapse=",")
)
})
)
The menuItems from the paste function doesn't resolve( I get the result of paste function on the sidebar). I tried eval, eval(parse(paste(...))), both didn't work - what am I missing?
I couldn't quite make out what you're asking for, but here's an example of something with a dynamic menu.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic Menu"),
dashboardSidebar(
sidebarMenuOutput(outputId = "dy_menu")
),
dashboardBody(
tabItems(
tabItem(tabName = "main",
textInput(inputId = "new_menu_name",
label = "New Menu Name"),
actionButton(inputId = "add",
label = "Add Menu")
)
)
)
)
server <- function(input, output, session){
output$dy_menu <- renderMenu({
menu_list <- list(
menuItem("Add Menu Items", tabName = "main", selected = TRUE),
menu_vals$menu_list)
sidebarMenu(.list = menu_list)
})
menu_vals = reactiveValues(menu_list = NULL)
observeEvent(eventExpr = input$add,
handlerExpr = {
menu_vals$menu_list[[length(menu_vals$menu_list) + 1]] <- menuItem(input$new_menu_name,
tabName = input$new_menu_name)
})
}
shinyApp(ui, server)
I changed the code as follows and it worked :
library(shiny)
library(shinydashboard)
port_tables<-c("tab1","tab2","tab3","tab4") # These are from a DB connection in the original code
text1<-paste("menuItem(\"",port_tables,"\",tabName=\"",port_tables,"\",icon=icon('th'))")
text2<-paste("sidebarMenu(id = 'tabs',textInput('port', 'Enter port:'),h4('Tables',style='color:yellow;margin-left:20px;'),",paste(text1,collapse=","),paste(")"))
function(input, output) {
output$smenu1 <- renderMenu({
eval(parse(text=text2))
})
)
So, the key is put the whole content of sidebarMenu in a text field and evaluate it

Resources