Multiple tabItems in one shiny module - r

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)

Related

Shiny Dashboard: Render multiple menu items and output dynamic content to each

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

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)

How to add the same inputs into two tabItems in shinydashboard?

I am using shinydashboard to create the interface of my shiny App. However I want one input which appear in the two tabMenu. In the example below, I want to textInput i_test appears in menu menu1 and menu2.
How should I implement it? Thanks for any suggestions.
library(shiny)
library(shinydashboard)
# Side bar boardy
sidebar <- dashboardSidebar(
sidebarMenu(
id = 'menu_tabs'
, menuItem('menu1', tabName = 'menu1')
, menuItem('menu2', tabName = 'menu2')
, menuItem('menu3', tabName = 'menu3')
)
)
# Body board
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'menu1',
textInput('i_test', 'Test')
),
tabItem(
tabName = 'menu2'
)
)
)
# Shiny UI
ui <- dashboardPage(
title = 'test',
dashboardHeader(),
sidebar,
body
)
server <- function(input, output, session) {
}
shinyApp(ui, server)
It seems that shiny always renders two distinct elements, even if you try to build the same element a second time.
Thats why i could only come up with a solution that only makes it look like the two text iputs are the same.
Check the Code:
library(shiny)
library(shinydashboard)
# Side bar boardy
sidebar <- dashboardSidebar(
sidebarMenu(
id = 'menu_tabs'
, menuItem('menu1', tabName = 'menu1')
, menuItem('menu2', tabName = 'menu2')
, menuItem('menu3', tabName = 'menu3')
)
)
# Body board
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'menu1',
textInput('i_test_1', 'Test')
),
tabItem(
tabName = 'menu2',
textInput('i_test_2', 'Test')
),
tabItem(
tabName = 'menu3'
)
)
)
# Shiny UI
ui <- dashboardPage(
title = 'test',
dashboardHeader(),
sidebar,
body
)
server <- function(input, output, session) {
observe({
text1 <- input$i_test_1
updateTextInput(session, 'i_test_2', value = text1)
})
observe({
text2 <- input$i_test_2
updateTextInput(session, 'i_test_1', value = text2)
})
}
shinyApp(ui, server)

How can I concise the code being generated in first panel?

library(shiny)
library(shinydashboard)
ui <- dashboardPage( skin="blue",title = "asdfasf",
dashboardHeader(title = "Fund Analysis Status Tool",titleWidth=255, .list=NULL),
dashboardSidebar( width = 255, sidebarMenu(menuItem("Analysis", icon = icon("th"),menuSubItem("ME-1", tabName = "Analysis-ME-1"),
menuSubItem("Current", tabName = "Analysis-Current")),menuItem("Post-Analysis1",icon = icon("th"),menuSubItem("ME-1", tabName = "Post_Analysis-ME-1"),menuSubItem("Current", tabName = "Post_Analysis-Current")))), # it gives heading in the left panel
dashboardBody(
tabItems(tabItem(tabName = "Analysis-ME-1",fluidRow(box(dataTableOutput('table')),box(title = "Controls",
sliderInput("slider", "Number of observations:", 1, 100, 50)))),
tabItem(tabName = "Analysis-Current",h2("To be discussed1")),
# Second tab content
tabItem(tabName = "Post_Analysis-ME-1", h2("To be discussed1")),
tabItem(tabName = "Post_Analysis-Current",h2("To be discussed2")))))
server <- function(input, output) {
histdata <- rnorm(500)
output$table <- renderDataTable(iris)
output$plot1 <- renderPlot({
data <- histdata[seq_len(input$slider)]
hist(data)
})
}
shinyApp(ui, server)
This is largely a matter of opinion on how you go about this. I've reorganized your code to how I might approach it below.
In the few applications I've built, my choice of strategy has varied by how large the application is. In smaller applications, I'll source in functions or define them in global.R and then use those functions throughout the application. More recently, I've started just writing each application as a stand alone package.
Either way, the general process is to break your application into small steps, write each of those steps into a function with a descriptive name (brevity isn't necessarily a virtue here), and then call the functions to generate your application.
library(shiny)
library(shinydashboard)
#* Put these in your global.R file, perhaps.
dashboard_header <- function(){
dashboardHeader(
title = "Fund Analysis Status Tool",
titleWidth=255,
.list=NULL
)
}
dashboard_sidebar <- function(){
dashboardSidebar(
width = 255,
sidebarMenu(
menuItem("Analysis", icon = icon("th"),
menuSubItem(
"ME-1",
tabName = "Analysis-ME-1"
),
menuSubItem(
"Current",
tabName = "Analysis-Current"
)
),
menuItem(
"Post-Analysis1",
icon = icon("th"),
menuSubItem(
"ME-1",
tabName = "Post_Analysis-ME-1"
),
menuSubItem(
"Current",
tabName = "Post_Analysis-Current"
)
)
)
)
}
tab_items <- function(){
tabItems(
# First tab content
tabItem(
tabName = "Analysis-ME-1",
fluidRow(
box( dataTableOutput('table') )
),
box(
title = "Controls",
sliderInput(
"slider",
"Number of observations:",
1,
100,
50
)
)
),
tabItem(
tabName = "Analysis-Current",
h2("To be discussed1")
),
# Second tab content
tabItem(
tabName = "Post_Analysis-ME-1",
h2("To be discussed1")
),
tabItem(
tabName = "Post_Analysis-Current",
h2("To be discussed2")
)
)
}
#***************************
#***************************
#* And now the ui and server
ui <-
dashboardPage(
skin="blue",
title = "asdfasf",
dashboard_header(),
dashboard_sidebar(),# it gives heading in the left panel
dashboardBody(
tab_items()
)
)
server <- shinyServer(function(input, output) {
histdata <- rnorm(500)
output$table <- renderDataTable(iris)
output$plot1 <- renderPlot({ data <- histdata[seq_len(input$slider)]
hist(data) })
})
shinyApp(ui, server)

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