shiny module namespace issue with dynamic creation of tabesetPanel - r

I am currently having troubles making my module UI and server communicating whith an intermediate renderUI creating the layout. Here is a repex with and without the dynamic creation of the tabsetPanel. I guess the problem comes from namespace but I cannot figure out where and how to fix it.
DO NOT WORK :
mod_graphical_general_ui <- function(id){
ns <- NS(id)
tagList(
selectInput(ns("myselect"), "Select a choice", choices = NULL)
)}
mod_graphical_general_server <- function(id, choices = NULL) {
moduleServer( id, function(input, output, session){
ns <- session$ns
updateSelectInput(session, "myselect", choices = choices)
})
}
ui <- bootstrapPage(
uiOutput("mytabs")
)
server <- function(input, output) {
mod_graphical_general_server("mymodule", choices = c("aaa", "bbb"))
output$mytabs = renderUI({
number_of_tabs <- 3
names_tab <- paste0("Tab", 1:number_of_tabs)
myTabs = lapply(1: number_of_tabs, function(x) {tabPanel(names_tab[[x]], div(uiOutput(paste0("graphics_tab", x))))})
do.call(tabsetPanel, c(myTabs))
})
output$graphics_tab1 <- renderUI({
return(mod_graphical_general_ui("mymodule"))
})
}
shinyApp(ui = ui, server = server)
If I remove the step from calling the tabsetPanel, the code works .
mod_graphical_general_ui <- function(id){
ns <- NS(id)
tagList(
selectInput(ns("myselect"), "Select a choice", choices = NULL)
)}
mod_graphical_general_server <- function(id, choices = NULL) {
moduleServer( id, function(input, output, session){
ns <- session$ns
updateSelectInput(session, "myselect", choices = choices)
})
}
ui <- bootstrapPage(
#uiOutput("mytabs")
uiOutput("graphics_tab1")
)
server <- function(input, output) {
mod_graphical_general_server("mymodule", choices = c("aaa", "bbb"))
output$mytabs = renderUI({
number_of_tabs <- 3
names_tab <- paste0("Tab", 1:number_of_tabs)
myTabs = lapply(1: number_of_tabs, function(x) {tabPanel(names_tab[[x]], div(uiOutput(paste0("graphics_tab", x))))})
do.call(tabsetPanel, c(myTabs))
})
output$graphics_tab1 <- renderUI({
return(mod_graphical_general_ui("mymodule"))
})
}
shinyApp(ui = ui, server = server)
I already have asked the question in the community rstudio but with no luck.

Anyway, I fixed your code.
The thing is your mod server is run as the top-level shiny server starts. However, your mod UI is running later after the mod server. So this causes the updateSelectInput can't find the dynamic UI component to update. In your second example, the UI component is already there when app starts, so it doesn't have this issue.
We need to wait the render UI event is done when we can call the mod server. To understand this, you need to know how Shiny communicates with frontend javascript, not going into details here. You can read more on this issue.
mod_graphical_general_ui <- function(id){
ns <- NS(id)
tagList(
selectInput(ns("myselect"), "Select a choice", choices = NULL)
)}
mod_graphical_general_server <- function(id, choices = NULL) {
moduleServer(id, function(input, output, session){
ns <- session$ns
updateSelectInput(session, "myselect", choices = choices)
})
}
ui <- bootstrapPage(
uiOutput("mytabs")
)
server <- function(input, output, session) {
output$mytabs = renderUI({
number_of_tabs <- 3
names_tab <- paste0("Tab", 1:number_of_tabs)
myTabs = lapply(1:number_of_tabs, function(x) {tabPanel(names_tab[[x]], div(uiOutput(paste0("graphics_tab", x))))})
do.call(tabsetPanel, c(myTabs))
})
output$graphics_tab1 <- renderUI({
on.exit({
observeEvent(once = TRUE, reactiveValuesToList(session$input), {
mod_graphical_general_server("mymodule", choices = c("aaa", "bbb"))
}, ignoreInit = TRUE)
})
return(mod_graphical_general_ui("mymodule"))
})
}
shinyApp(ui = ui, server = server)

Related

Unable to access the value of radioButton when created inside a shiny server module

My shinyapp is build using modules, the radioBox component inputId = modelling_type is created in the server, using a renderUI function and stored under outputId = modelling_type_ui
As I'm using modules, I have name spaced my IDs in the mod_ui, and then in order to (attempt!) to use the same name space function in the mod_server I have called it via ns <- parentsession$ns. This doesn't throw an error. But I would now expect to access the value of the RadioBox via input$modelling_type
This isn't working! So I must be calling the value incorrectly.
Here is the code:
library(shiny)
library(shinyalert)
library(shinydashboard)
library(shinyjs)
library(tidyverse)
# modules ------------------------------------------
mod_ui <- function(id){
ns <- NS(id)
fluidPage(
uiOutput(outputId = ns("modelling_type_ui")),
textOutput(outputId = ns("capture"))
)
}
mod_server <- function(id, parentsession){
moduleServer(id,
function(input, output, server){
ns <- parentsession$ns
output$modelling_type_ui = renderUI({
print(input$modelling_type) # this should not be null
radioButtons(
inputId = ns("modelling_type"),
label = "Choose a modelling technique",
choices = c("OLS",
"Bayesian"),
selected = "OLS")
})
output$capture = renderText({ paste0("modelling type selected:", input$modelling_type) })
})
}
# call app ---------------------------------------
# run app
ui <- function(){ mod_ui("mt") }
server <- function(input, output, session){ mod_server("mt", session) }
shinyApp(ui = ui, server = server)
Any help appreciated. Usually I would just call radioButtons in the UI, and use updateradioButtons function in the server, but I'm dealing with a legacy app which uses the below method repeatedly.
To expand on my comment above, here is a MWE that I believe does what you want.
I'm not sure why you're using uiOutput and renderUI. I assume it's needed in your actual use case, but it's not needed here. Also, there's no need to muck about with parentsession and the like.
One reason why your debug print prints NULL is that you haven't defined the radio group at the time you try to print its value.
library(shiny)
library(tidyverse)
mod_ui <- function(id){
ns <- NS(id)
fluidPage(
uiOutput(outputId = ns("modelling_type_ui")),
textOutput(outputId = ns("capture"))
)
}
mod_server <- function(id) {
moduleServer(
id,
function(input, output, session){
ns <- session$ns
output$modelling_type_ui = renderUI({
radioButtons(
inputId = ns("modelling_type"),
label = "Choose a modelling technique",
choices = c("OLS","Bayesian"),
selected = "OLS"
)
})
output$capture <- renderText({
paste0("modelling type selected: ", input$modelling_type)
})
rv <- reactive({
input$modelling_type
})
return(rv)
}
)
}
ui <- function() {
fluidPage(
mod_ui("mt"),
textOutput("returnValue")
)
}
server <- function(input, output, session) {
modValue <- mod_server("mt")
output$returnValue <- renderText({
paste0("The value returned by the module is ", modValue())
})
}
shinyApp(ui = ui, server = server)

How to dynamically update dropdown within a modulized shinyalert for each iteration of a for loop, when using html = TRUE?

I'm creating a shiny module, where I wish to display some pop-up messages to the user via shinyalerts and include dropdown menus via htlm = TRUE and shinyWidgets::pickerInput. For each shinyalert the options should be different and the alerts should appear right after each other when the user has selected the relevant option.
However, when running the shinyalerts within a for loop, only the first alert shows the drop-down, the following does not. Please have a look at the example below and screenshots. Any ideas what I'm doing wrong?
Module UI:
mod_match_columns_ui <- function(id){
ns <- NS(id)
tagList(
shinyalert::useShinyalert(),
actionButton(ns("run"), label = "Start!")
)
}
Module server:
mod_match_columns_server <- function(input, output, session){
ns <- session$ns
options <- list(c("option_1","option_2"),
c("option_3","option_4"))
observeEvent(input$run, {
for(col in 1:2){
nms <- options[[i]]
output[[paste0("dropdown",col)]] <- renderUI({
shinyWidgets::pickerInput(
inputId = ns(paste0("options",col)),
label = "Options listed below",
choices = nms,
selected = "",
multiple = FALSE,
options = shinyWidgets::pickerOptions(size = 15)
)
})
shinyalert::shinyalert(
title = "Pick an option!",
html = TRUE,
text = tagList(
uiOutput(ns(paste0("dropdown", col)))
),
inputId = ns(paste0("modal", col))
)
}
})
}
Run module:
library(shiny)
ui <- fluidPage(
mod_match_columns_ui("match_columns_ui_1")
)
server <- function(input, output, session) {
callModule(mod_match_columns_server, "match_columns_ui_1")
}
shinyApp(ui = ui, server = server)
First iteration:
Second iteration:
Why is the dropdown not shown in the second iteration?? Thanks
Try this
library(shiny)
library(shinyalert)
mod_match_columns_ui <- function(id){
ns <- NS(id)
tagList(
shinyalert::useShinyalert(),
actionButton(ns("run"), label = "Start!")
)
}
mod_match_columns_server <- function(id) {
moduleServer(id,
function(input, output, session) {
ns <- session$ns
options <- list(c("option_1","option_2"),
c("option_3","option_4"))
lapply(1:2, function(col){
output[[paste0("dropdown",col)]] <- renderUI({
shinyWidgets::pickerInput(
inputId = ns(paste0("options",col)),
label = paste("Options",col,"listed below"),
choices = options[[col]],
selected = "",
multiple = FALSE,
options = shinyWidgets::pickerOptions(size = 15)
)
})
})
observeEvent(input$run, {
shinyalert::shinyalert(
title = "Pick an option!",
html = TRUE,
text = tagList(
lapply(1:2, function(i){uiOutput(ns(paste0("dropdown",i)))})
)
# callbackR = function(x) { message("Hello ", x) },
# inputId = ns(paste0("modal"))
)
})
observe({
print(input$options1)
print(input$options2)
print(input$shinyalert)
})
})
}
ui <- fluidPage(
tagList(
mod_match_columns_ui("match_columns_ui_1")
)
)
server <- function(input, output, session) {
mod_match_columns_server("match_columns_ui_1")
}
shinyApp(ui = ui, server = server)

How to bookmark and restore dynamically added modules?

I am trying to save and restore an app that uses modules which render UI outputs dynamically.
I hoped the bookmarking function would work with the app and I added the bookmarkButton and enabled bookmarking using enableBookmarking = "server". I've also made the ui a function. I learned that bookmarking works with modules, but I'm unable to find a way to get it working with dynamically created UI inputs and outputs. Only the last input and output are restored. The others are not restored.
Example app:
library(shiny)
histogramUI <- function(id) {
tagList(
fluidRow(column( 4, selectInput(NS(id, "var"), "Variable", choices = names(mtcars)),
numericInput(NS(id, "bins"), "bins", value = 10, min = 1)),
column(8, plotOutput(NS(id, "hist"))))
)
}
histogramServer <- function(id) {
moduleServer(id, function(input, output, session) {
data <- reactive(mtcars[[input$var]])
output$hist <- renderPlot({
hist(data(), breaks = input$bins, main = input$var)
}, res = 96)
})
}
ui <- function(request){
fluidPage(
bookmarkButton(),
actionButton("add", "Add"),
div(id = "add_here")
)
}
server <- function(input, output, session) {
observeEvent(input$add, {
histogramServer(paste0("hist_", input$add))
insertUI(selector = "#add_here", ui = histogramUI(paste0("hist_", input$add)))
})
}
shinyApp(ui, server, enableBookmarking = "server")
Only the last input and plot output are restored:
One would expect all module instances to be restored, but as you pointed out, only the last one is restored due to addbutton restoration.
As a workaround, you could store the module instances list stored in state$exclude with onBookmark and re-create the instances of the module with onRestore.
histogramUI was modified in order to accept var,bins as new parameters for creation of the modules.
Another important point is to use setBookmarkExclude so that the add button doesn't create the last module at restoration. As the button isn't anymore bookmarked, it's value should be also be saved with onBookmark.
Try:
library(shiny)
histogramUI <- function(id,var,bins) {
tagList(
fluidRow(column( 4, selectInput(NS(id, "var"), "Variable", choices = names(mtcars),selected=var),
numericInput(NS(id, "bins"), "bins", value = bins, min = 1)),
column(8, plotOutput(NS(id, "hist"))))
)
}
histogramServer <- function(id) {
moduleServer(id, function(input, output, session) {
data <- reactive(mtcars[[input$var]])
output$hist <- renderPlot({
hist(data(), breaks = input$bins, main = input$var)
}, res = 96)
})
}
ui <- function(request){
fluidPage(
bookmarkButton(),
actionButton("add", "Add Histogram"),
div(id = "add_here")
)
}
server <- function(input, output, session) {
add_id <- reactiveVal(0) # To save 'add' button state
setBookmarkExclude('add') # Don't add new module at restoration
observeEvent(input$add, {
histogramServer(paste0("hist_", input$add+add_id()))
insertUI(selector = "#add_here", ui = histogramUI(paste0("hist_", input$add+add_id()),'mpg',10))
})
onBookmark(function(state) {
modules <- state$exclude
state$values$modules <- modules[grepl("hist",modules)] # only 'hist' (without 'add')
state$values$add <- state$input$add + add_id() # add button state
})
onRestore(function(state){
# Restore 'add' last state
add_id(state$values$add)
# Restore 'hist' modules
modules <- state$values$modules
if (length(modules)>0) {
for (i in 1:(length(modules))) {
histogramServer(modules[i])
insertUI(selector = "#add_here", ui = histogramUI(modules[i],paste0(modules[i],"-var"),paste0(modules[i],"-bin")))
}
}
})
}
shinyApp(ui, server, enableBookmarking = "server")
Another way to do it:
library(shiny); library(purrr)
histogramUI <- function(id) {
ns <- NS(id)
tagList(
fluidRow(column( 4, selectInput(ns("var"), "Variable", choices = names(mtcars)),
numericInput(ns("bins"), "bins", value = 10, min = 1)),
column(8, plotOutput(ns("hist"))))
)
}
histogramServer <- function(id) {
moduleServer(id, function(input, output, session) {
vals <- reactiveValuesToList(input)
data <- reactive(mtcars[[input$var]])
output$hist <- renderPlot({
hist(data(), breaks = input$bins, main = input$var)
}, res = 96)
#to avoid inputs resetting after adding another.
if(length(vals) != 0) {
updateSelectInput(session, 'var', "Variable", choices = names(mtcars), selected = vals$var)
updateNumericInput(session, 'bins', "bins", value = input$bins, min = 1,)
}
})
}
ui <- function(request){
fluidPage(
bookmarkButton(),
actionButton("add", "Add"),
uiOutput('histogram_module')
)
}
server <- function(input, output, session) {
observeEvent(input$add, {
#the server module
map(1:input$add, ~histogramServer(paste0("hist_", .x)))
#the ui module
output$histogram_module <- renderUI({ map(1:input$add, ~histogramUI(id = paste0("hist_", .x))) })
})
}
shinyApp(ui, server, enableBookmarking = "server")

Piping a global input into a Shiny module

Suppose I have the following Shiny module, which doesn't work as I intend:
library(shiny)
# module
module_ui <- function(id) {
ns <- NS(id)
uiOutput(ns("choose"))
}
module_server <- function(input, output, session) {
output$choose <- renderUI({
selectInput(inputId = "option",
label = "choose your option",
choices = c("a", "b", input$entered_text))
})
}
# ui and server
ui <- fluidPage(
textInput("entered_text", label = "Enter a custom option:"),
module_ui("xyz")
)
server <- function(input, output, session) {
callModule(module_server, "xyz")
}
shinyApp(ui, server)
How can I pipe the global input, input$entered_text (Line 10), into the module so that the text that the user entered shows up as a choice on the selectInput UI?
I think I am supposed to use reactive(), but I must be doing something wrong.
Indeed, you are supposed to use reactive() and pass the result of the entered_text to your module, as such:
library(shiny)
# module
module_ui <- function(id) {
ns <- NS(id)
uiOutput(ns("choose"))
}
module_server <- function(input, output, session, et) {
output$choose <- renderUI({
selectInput(inputId = "option",
label = "choose your option",
choices = c("a", "b", et()))
})
}
# ui and server
ui <- fluidPage(
textInput("entered_text", label = "Enter a custom option:"),
module_ui("xyz")
)
server <- function(input, output, session) {
et <- reactive(input$entered_text)
callModule(module_server, "xyz", et)
}
shinyApp(ui, server)

How do I convert this into a shiny module

Can you provide a MWE of modularized shiny code that uses renderUI? I'd like an example to follow.
There is an excellent tutorial that discusses this here: https://shiny.rstudio.com/articles/modules.html however, it doesn't show how to integrate the modularization of renderUI components in the ui nor in the server.
Here's what I've tried so far:
In my ui code, I had:
htmlOutput("selectionUI")
In my server code, I had:
output$selectionUI <- renderUI({
req(input$Filter)
selectInput(
inputId = "Selection",
label = "Selection",
choices = get("qlist", envir = get(input$source))[[input$Filter]]$responses)
})
Now I would like to modularize this becuase it's a sometimes repeated element, but I'm not sure how to actually insert it into my ui/server code once I'm done.
Here's what I've tried:
selectionChooserUI <- function(id) {
ns <- NS(id)
uiOutput(ns('controls'))
}
selectionChooser <- function(input, output, session, data, sourcedata, filter) {
output$selectionUI <- renderUI({
req(input$Filter)
ns <- session$ns
selectInput(
inputId = ns('Selection'),
label = 'Selection',
choices = get('qlist', envir = get(input[[sourcedata()]]))[[input[[filter()]]]]$responses
)
})
}
What do I have to put into my ui code to get it to diplay, currently I'm getting complaints that "output" is missing with no default?
I'm calling it presently in my ui code, using:
selectionChooserUI("selection")
It's probably something like this. I haven't test it out since I don't have your data ..
library(shiny)
ui <- fluidPage(
h1("Get me a Module!"),
selectInput("source", "Some source", choices = letters[1:4]),
selectInput("filter", "Some filter", choices = letters[1:4]),
selectionChooserUI("id_of_me")
)
server <- function(input, output, session) {
get_me_choices <- reactive({
get("qlist", envir = get(req(input$source)))[[req(input$filter)]]$responses })
callModule(module = selectionChooser, id = "id_of_me", choices = get_me_choices)
}
selectionChooserUI <- function(id) {
ns <- NS(id)
uiOutput(ns('selection'))
}
selectionChooser <- function(input, output, session, choices) {
ns <- session$ns
output$selection <- renderUI({
selectInput(
inputId = ns('selection'),
label = 'Selection',
choices = choices
)
})
}

Resources