R Shinydashboard dynamic menuItem - r

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

Related

Multiple tabItems in one shiny module

Hello im relatively new to R Programming and Shiny.
I´m currently developing an shiny dashboard application.
I´m stuck a the moment with the problem of how to have multiple tabItems in one module.
In the real app I need to pass a lot more information's between the modules and the submenu's aren't alike. So is there a way to make this work?
Thanks so much for your help!
library(shiny)
library(shinydashboard)
library(shinydasboardPlus)
#submodules
submodule_ui <- function(id,tabName){
ns <- NS(id)
tabItem(
tabName = tabName,
boxPlus(
title = "some title",
textOutput(ns("some_output"))
)
)
}
submodule_server <- function(id,see){
moduleServer(
id,
function(input, output, session){
output$some_output <- renderText({
see
})
}
)
}
#module
module_ui <- function(id,tabName1,tabName2){
ns <- NS(id)
submodule_ui(ns("sub1"),
tabName = tabName1)
submodule_ui(ns("sub2"),
tabName = tabName2)
}
module_server <- function(id){
moduleServer(
id,
function(input, output, session){
submodule_server("sub1","hello")
submodule_server("sub2","world !")
}
)
}
#app
ui <- dashboardPagePlus(
header = dashboardHeaderPlus(
title = "dummy app"
),
sidebar = dashboardSidebar(
sidebarMenu(
menuItem(
text = "home",
tabName = "home"
),
menuItem(
text = "submodule1",
tabName = "subtab1"
),
menuItem(
text = "submodule2",
tabName = "subtab2"
),
menuItem(
text = "some other tabItems",
tabName = "some_other_tabItems"
)
)
),
body = dashboardBody(
tabItems(
tabItem(
tabName = "home",
box(
title = "home of the app",
width = "auto"
)
),
module_ui(
id = "module",
tabName1 = "subtab1",
tabName2 = "subtab2"
),
tabItem(
tabName = "some_other_tabItems",
box(
title = "some other content"
)
)
)
)
)
server <- function(input, output){
module_server("module")
}
shinyApp(ui,server)
´´´
It appears there was some issues with getting the tab item wrapper around the submodules - it was only producing the second submodule. Modules act like functions as they tend to produce the final call. You can wrap things in a list or taglist to return more items. In the meantime...
By moving the tabItems wrapper into the module, it was able to create the list properly and produce both tabs.
Note: I converted the functions to shinydashboard as I could figure out where the xxxPlus functions came from.
library(shiny)
library(shinydashboard)
#submodules
submodule_ui <- function(id,tabName){
ns <- NS(id)
tabItem(
tabName = tabName,
box(
title = "some title",
textOutput(ns("some_output"))
)
)
}
submodule_server <- function(id,see){
moduleServer(
id,
function(input, output, session){
output$some_output <- renderText({
see
})
}
)
}
#module
module_ui <- function(id,tabName1,tabName2){
ns <- NS(id)
### tabsItems now produced in module, submodules separated by comma
tabItems(
submodule_ui(ns("sub1"),
tabName = tabName1),
submodule_ui(ns("sub2"),
tabName = tabName2)
)
}
module_server <- function(id){
moduleServer(
id,
function(input, output, session){
submodule_server("sub1","hello")
submodule_server("sub2","world !")
}
)
}
#app
ui <- dashboardPage(
header = dashboardHeader(
title = "dummy app"
),
sidebar = dashboardSidebar(
sidebarMenu(
menuItem(
text = "submodule1",
tabName = "subtab1"
),
menuItem(
text = "submodule2",
tabName = "subtab2"
)
)
),
body = dashboardBody(
module_ui(
id = "module",
tabName1 = "subtab1",
tabName2 = "subtab2"
)
)
)
server <- function(input, output){
module_server("module")
}
shinyApp(ui,server)

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.

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

R Shiny create menuItem after object is created/button clicked

I'm trying to dynamically generate a menuItem upon the creation of an object or click of a button (Ideally object). I have tried multiple methods and cannot seem to figure out a clean, working solution.
I have a lot of code so below shall include example code:
ui <- fluidPage(
dashboardPage(
dashboardHeader(title = "text"),
dashboardSidebar(
sidebarMenu(id = 'MenuTabs',
menuItem("Tab1", tabName = "tab1", selected = TRUE)
# menuItem("Tab1", tabName = "tab2")
)
),
dashboardBody(
tabItems(
tabItem("tab1",
actionButton("newplot", "New plot")),
tabItem("tab2",
plotOutput('Plot'))
)
)
)
)
server <- function(input, output, session){
output$Plot <- renderPlot({
input$newplot
cars2 <- cars + rnorm(nrow(cars))
plot(cars2)
})
}
shinyApp(ui, server)
Above I have 2 tabs, 1 with a button (shown), and another with a plot (hidden).
How can I get the hidden tab with the plot to appear upon clicking the button?
For bonus points, assuming the button instead created an object, how could I show the hidden menuItem given the creating of said object
Thanks
I've managed to solve it. Below is the code that will create a menuItem by pressing a button show.
ui <- fluidPage(
dashboardPage(
dashboardHeader(title = "text"),
dashboardSidebar(
sidebarMenu(id = 'MenuTabs',
menuItem("Tab1", tabName = "tab1", selected = TRUE),
# menuItem("Tab1", tabName = "tab2")
uiOutput('ui')
)
),
dashboardBody(
tabItems(
tabItem("tab1",
actionButton("newplot", "New plot"),
actionButton("show", "Show")),
tabItem("tab2",
plotOutput('Plot'))
)
)
)
)
server <- function(input, output, session){
output$Plot <- renderPlot({
input$newplot
# Add a little noise to the cars data
cars2 <- cars + rnorm(nrow(cars))
plot(cars2)
})
output$ui <- renderUI({
if(input$show == 0) return()
print(input$show)
sidebarMenu(id = 'MenuTabs',
menuItem("Tab1", tabName = "tab2")
)
})
}
shinyApp(ui, server)

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))
)
}
)
})
}

Resources