I have a question regarding dynamic content inside R shinydashboard dynamic tabItems
.
I am successfully able to generate dynamic sidebar menu and corresponding dynamic body tabs.
However, each time I create a new tab (or remove an existing ones), dynamic content inside existing dynamic tabs is lost .
Below is a MWE where the user can add and remove named tabs (from Setup
tab). Inside each dynamic tab, the user can enter some text. If the user navigates between existing tabs, it is ok and the input text is kept. But, when the user adds or removes a tabs, the dynamic content of existing tabs is lost.
I understand the reason, each time the dynamic tab list is modified, all dynamic contents are regenerated, but I do not know a workaround. To my knowledge, shinydashboard does not have insert/remove tab functions, like insertTab
and removeTab
for shiny::tabsetPanel
.
# credit: adapted from https://mgei.github.io/post/dynamic-shinydashboard/
library(shiny)
library(shinydashboard)
# ui
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenuOutput("mysidebar")
),
dashboardBody(
uiOutput("mycontent")
)
)
# server
server <- function(input, output, session) {
# This is to get the desired menuItem selected initially.
# selected=T seems not to work with a dynamic sidebarMenu.
observeEvent(session, {
updateTabItems(session, "tabs", selected = "setup")
})
# store dynamic tab list and dynamic contents
local <- reactiveValues(
subitems = list(),
dynamic_tabs = list()
)
# dynamic sidebar menu #
output$mysidebar <- renderMenu({
sidebarMenu(
id = "tabs",
menuItem(
"Setup", tabName = "setup",
icon = icon("gear"), selected = T
),
menuItem(
"Subs", id = "subs", tabName = "subs",
icon = icon("dashboard"), startExpanded = T,
lapply(local$subitems, function(x) {
menuSubItem(x, tabName = paste0("sub_", x))
})
)
)
})
# dynamic content #
output$mycontent <- renderUI({
# concatenate with static tabs
items <- c(
list(
tabItem(
tabName = "setup",
textInput("add_subitem", "Add subitem"),
actionButton("add", "add!"),
selectInput("rm_subitem", "Remove subitem",
choices = local$subitems),
actionButton("rm", "remove!")
)
),
unname(local$dynamic_tabs)
)
# render
do.call(tabItems, items)
})
# add a tab
observeEvent(input$add, {
req(input$add_subitem)
subitem <- input$add_subitem
local$subitems <- append(local$subitems, subitem)
updateTabItems(session, "tabs", selected = "setup")
# dynamic tab list update
local$dynamic_tabs[[ subitem ]] <- tabItem(
tabName = paste0("sub_", subitem),
uiOutput(paste0("sub_", subitem))
)
# dynamic content in the dynamic subitem
output[[ paste0("sub_", subitem) ]] <- renderUI ({
list(
fluidRow(
box("hello ", subitem),
box(
textInput(
paste0("tell_me_", subitem),
label = "tell me"
),
verbatimTextOutput(
paste0("print_", subitem),
placeholder = TRUE
)
)
)
)
})
# update dynamic content in the created subitem
observe({
req(input[[ paste0("tell_me_", subitem) ]])
output[[ paste0("print_", subitem) ]] <- renderText({
input[[ paste0("tell_me_", subitem) ]]
})
})
})
# remove a tab
observeEvent(input$rm, {
req(input$rm_subitem)
subitem <- input$rm_subitem
local$subitems = local$subitems[-which(local$subitems == subitem)]
updateTabItems(session, "tabs", selected = "setup")
# dynamic tab list
local$dynamic_tabs[[ subitem ]] <- NULL
})
}
shinyApp(ui, server)
Edit1: I simplified the MWE. And I understand that output$mycontent <- renderUI({... })
recreates all tabs whenever one is created/deleted. My current workaround would be to create a static list of tabs, and dynamically fill them/add them to the sidebar menu.
Here is a MWE for a workaround that consists in setting up a static list of tabs, which are not shown in the sidebarMenu
by default.
When the user "adds" a tabs, it is made available and appears in the sidebarMenu
.
When the user "removes" a tab, it is removed from the sidebarMenu
and its input is reset so it can be used again (if the user decides to add a new tab).
The Setup
page is now dynamic to account for tab names.
Advantages:
Problems:
# credit: adapted from https://mgei.github.io/post/dynamic-shinydashboard/
library(shiny)
library(shinydashboard)
library(shinyjs)
options(stringsAsFactors = FALSE)
# static tab list
tab_list_ui <- function() {
# concatenate static tabs
items <- c(
list(
tabItem(
tabName = "setup",
uiOutput("mysetup")
)
),
lapply(1:10, function(id) {
tabItem(
tabName = paste0("tab_", id),
uiOutput(paste0("sub_", id))
)
})
)
# render
do.call(tabItems, items)
}
# dynamic sub menu
update_submenu <- function(local) {
lapply(split(local$subitems, seq(nrow(local$subitems))), function(x) {
menuSubItem(x$name, tabName = paste0("tab_", x$id))
})
}
# ui
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenuOutput("mysidebar")
),
dashboardBody(
tab_list_ui()
)
)
# server
server <- function(input, output, session) {
# This is to get the desired menuItem selected initially.
# selected=T seems not to work with a dynamic sidebarMenu.
observeEvent(session, {
updateTabItems(session, "tabs", selected = "setup")
})
# render setup
output$mysetup <- renderUI({
tagList(
textInput("add_subitem", "Add subitem"),
actionButton("add", "add!"),
selectInput("rm_subitem", "Remove subitem",
choices = local$subitems$name),
actionButton("rm", "remove!")
)
})
# store dynamic tab list and dynamic contents
local <- reactiveValues(
empty_tabs = as.list(1:10),
current_tabs = list(),
subitems = data.frame(id = integer(), name = character())
)
# dynamic sidebar menu #
output$mysidebar <- renderMenu({
sidebarMenu(
id = "tabs",
menuItem(
"Setup", tabName = "setup",
icon = icon("gear"), selected = T
),
menuItem(
"Subs", id = "subs", tabName = "subs",
icon = icon("dashboard"), startExpanded = T,
update_submenu(local)
)
)
})
# debugging
observe({
print(paste0("current tabs = ",
paste0(unlist(local$current_tabs), collapse = " ")))
print(paste0("empty tabs = ",
paste0(unlist(local$empty_tabs), collapse = " ")))
})
# add a tab
observeEvent(input$add, {
req(input$add_subitem)
req(length(local$empty_tabs) > 0)
# id of next tab to fill
id <- min(unlist(local$empty_tabs))
# update empty/current tab lists
local$empty_tabs <- local$empty_tabs[-which(local$empty_tabs == id)]
local$current_tabs <- append(local$current_tabs, id)
# tab name
subitem <- input$add_subitem
local$subitems <- rbind(local$subitems,
data.frame(id = id, name = subitem))
updateTabItems(session, "tabs", selected = "setup")
# dynamic content in the dynamic subitem
output[[ paste0("sub_", id) ]] <- renderUI ({
list(
fluidRow(
box("hello ", subitem),
box(
textInput(
paste0("tell_me_", id),
label = "tell me"
),
verbatimTextOutput(
paste0("print_", id),
placeholder = TRUE
)
)
)
)
})
# update dynamic content in the created subitem
observe({
req(input[[ paste0("tell_me_", id) ]])
output[[ paste0("print_", id) ]] <- renderText({
input[[ paste0("tell_me_", id) ]]
})
})
})
# remove a tab
observeEvent(input$rm, {
req(input$rm_subitem)
req(length(local$empty_tabs) < 10)
# id of tab to fill
subitem_ind <- which(local$subitems$name == input$rm_subitem)
subitem <- local$subitems[subitem_ind,]
# update empty/current tab lists
local$empty_tabs <- append(local$empty_tabs, subitem$id)
local$current_tabs <- local$current_tabs[-which(local$current_tabs == subitem$id)]
# reset deleted tab
shinyjs::reset(paste0("sub_", subitem$id))
# tab name
local$subitems <- local$subitems[-subitem_ind,]
updateTabItems(session, "tabs", selected = "setup")
})
}
shinyApp(ui, server)
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.