R Shiny: Dynamically calling modules depending on user input - r

I am trying to create an app that will dynamically call modules depending on user input. In this example, I have a simple selectInput() which defaults to 1, with choices 1 and 2. What I want is for any time the user selects 1, the server calls a "first" module, which just has a textInput() box that displays "Your selection is (user input)", or in the case of 1, "Your selection is 1". Otherwise, if user selects 2, I want to call a different module, which is an add/remove button module, which in turn calls "first" module. Essentially, it selectInput() value of 2 will do the same as selectInput() value of 1, except that in addition to the UI output of "first" module, it will have an add and remove action button that if pressed will call more of the "first" module ui and server components. I have it working if 1 is selected, but for selectInput() of 2, it does not seem to call the addRmBtn module. Code below, thanks!
library(shiny)
firstUI <- function(id) { uiOutput(NS(id, "first")) }
firstServer <- function(input, output, session, inData) {
ns = session$ns
output$first <- renderUI({
textInput(ns("selection"), ns("selection"), value = paste0("Your selection is ", inData))
})
}
removeFirstUI <- function(id) {
removeUI(selector = paste0('#', NS(id, "first")))
}
addRmBtnUI <- function(id) {
ns <- NS(id)
tags$div(
actionButton(inputId = ns('insertParamBtn'), label = "Add"),
actionButton(ns('removeParamBtn'), label = "Remove"),
hr(),
tags$div(id = ns('placeholder'))
)
}
addRmBtnServer <- function(input, output, session, moduleToReplicate, ...) {
ns = session$ns
params <- reactiveValues(btn = 0)
observeEvent(input$insertParamBtn, {
params$btn <- params$btn + 1
callModule(moduleToReplicate$server, id = params$btn, ...)
insertUI(
selector = paste0('#', ns('placeholder')),
ui = moduleToReplicate$ui(ns(params$btn))
)
})
observeEvent(input$removeParamBtn, {
moduleToReplicate$remover(ns(params$btn))
params$btn <- params$btn - 1
})
}
ui <- fluidPage(
#addRmBtnUI("addRm"),
column(12, selectInput("inp", label = "Select", choices = list(1, 2), selected = 1)),
column(12, uiOutput("inpChoice"))
)
server <- function(input, output, session) {
observeEvent(input$inp, {
if (input$inp == 1) {
callModule(firstServer, id = 0, inData = input$inp)
output$inpChoice <- renderUI({ firstUI(0) })
} else {
callModule(addRmBtnServer,
id = "inpChoice",
moduleToReplicate = list(
ui = firstUI,
server = firstServer,
remover = removefirstIU
),
inData = input$inp
)
}
})
}
shinyApp(ui = ui, server = server)

Try using a conditionalPanel() in the UI to adapt the conditions to the user input.
Maybe something like
conditionalPanel(condition = "input.inp=='2'",[do second module stuff here])

Related

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)

R Shiny: How to pass reactive variables between nested modules

I have created a toy example in which a textInput() box pops up for the user to input any string, and by clicking the add button, a selectInput() box pops up with the letters a:d prepended with the string. In other words, if the user inputs "1", then by clicking the "add" button, a selectInput() box pops up with 1a, 1b, 1c, and 1d as choices. I am using a module for the add/remove button functionality, and that module calls another module to generate the selectInput() box. The main server function calls the add/remove module, which calls the "first" module, which generates the selectInput() box. I pass a() as a reactive element to add/remove module, which in turn passes this on to "first" module. I just used "..." in the function signature of both the add/remove module and the "first" module to get a() to the nested module.
This seems to work, although a() seems to not be reactive by the time it gets to "first" module, meaning that if I type a different string in the "a" box, I would expect that the choices in the selectInput() box to change dynamically, or at least when I change the textInput() string and click "add", the new selectInput() should reflect the updated textInput() string, but this does not happen. What will make the selectInput() choices change dynamically with changes to textInput()? Code below, thanks!
library(shiny)
firstUI <- function(id) { uiOutput(NS(id, "first")) }
firstServer <- function(input, output, session, a) {
output$first <- renderUI({
selectInput(session$ns("select"), h4("Select"), paste0(a,letters[1:4]))
})
}
removeFirstUI <- function(id) {
removeUI(selector = paste0('#', NS(id, "first")))
}
addRmBtnUI <- function(id) {
ns <- NS(id)
tags$div(
actionButton(inputId = ns('insertParamBtn'), label = "Add"),
actionButton(ns('removeParamBtn'), label = "Remove"),
hr(),
tags$div(id = ns('placeholder'))
)
}
addRmBtnServer <- function(input, output, session, moduleToReplicate,...) {
ns = session$ns
params <- reactiveValues(btn = 0)
observeEvent(input$insertParamBtn, {
params$btn <- params$btn + 1
callModule(moduleToReplicate$server, id = params$btn, ...)
insertUI(
selector = paste0('#', ns('placeholder')),
ui = moduleToReplicate$ui(ns(params$btn))
)
})
observeEvent(input$removeParamBtn, {
moduleToReplicate$remover(ns(params$btn))
params$btn <- params$btn - 1
})
}
ui <- fluidPage(
addRmBtnUI("addRm"),
textInput("a", label = "a", value = 1, width = '150px') )
server <- function(input, output, session) {
a <- reactive({ input$a })
callModule(
addRmBtnServer, id = "addRm",
moduleToReplicate = list(
ui = firstUI,
server = firstServer,
remover = removeFirstUI
), a = a()
)
}
shinyApp(ui = ui, server = server)
If you have
a <- reactive({input$a})
you need to pass a down to the inner (first) module, not a(). That is because a() represents the current value of the observable object a. This means a() is not observable. In your code, a() is evaluated in the server scope during startup. At that time, a has the value 1 (the default value defined in the corresponding textInput) and you pass it as a static object.
You can learn more about reactive values here.
library(shiny)
firstUI <- function(id) { uiOutput(NS(id, "first")) }
firstServer <- function(input, output, session, a) {
output$first <- renderUI({
selectInput(session$ns("select"), h4("Select"), paste0(isolate(a()),letters[1:4]))
})
}
removeFirstUI <- function(id) {
removeUI(selector = paste0('#', NS(id, "first")))
}
addRmBtnUI <- function(id) {
ns <- NS(id)
tags$div(
actionButton(inputId = ns('insertParamBtn'), label = "Add"),
actionButton(ns('removeParamBtn'), label = "Remove"),
hr(),
tags$div(id = ns('placeholder'))
)
}
addRmBtnServer <- function(input, output, session, moduleToReplicate,...) {
ns = session$ns
params <- reactiveValues(btn = 0)
observeEvent(input$insertParamBtn, {
params$btn <- params$btn + 1
callModule(moduleToReplicate$server, id = params$btn, ...)
insertUI(
selector = paste0('#', ns('placeholder')),
ui = moduleToReplicate$ui(ns(params$btn))
)
})
observeEvent(input$removeParamBtn, {
moduleToReplicate$remover(ns(params$btn))
params$btn <- params$btn - 1
})
}
ui <- fluidPage(
addRmBtnUI("addRm"),
textInput("a", label = "a", value = 1, width = '150px') )
server <- function(input, output, session) {
a <- reactive({ input$a })
callModule(
addRmBtnServer, id = "addRm",
moduleToReplicate = list(
ui = firstUI,
server = firstServer,
remover = removeFirstUI
),
a = a
)
}
shinyApp(ui = ui, server = server)
Based on the example here, i've tweaked a little for the desired output.
app.R
library(shiny)
ui <- fluidPage(
actionButton('insertBtn', 'Insert'),
actionButton('removeBtn', 'Remove'),
tags$div(id = 'placeholder'),
textInput(inputId = "a", label = "a", value = 1, width = '150px')
)
server <- function(input, output) {
## keep track of elements inserted and not yet removed
inserted <- c()
observeEvent(input$insertBtn, {
btn <- input$a
id <- paste0('txt', btn)
insertUI(
selector = '#placeholder',
## wrap element in a div with id for ease of removal
ui = tags$div(
selectInput(inputId = btn,label = btn,choices = paste(btn,letters[1:4])),
id = id
)
)
inserted <<- c(id, inserted)
})
observeEvent(input$removeBtn, {
removeUI(
## pass in appropriate div id
selector = paste0('#', inserted[length(inserted)])
)
inserted <<- inserted[-length(inserted)]
})
}
shinyApp(ui = ui, server = server)
This results in app like :
As observed, the selectInputs are added based on a.

R Shiny: How to pass modules as parameters to other modules, and call those modules kin the new module

I am trying to decompose an unwieldy app that I have created, and in doing so I realize that I really need to modularize add/remove buttons. I want to be able to create a shiny module that has an add and remove button, and by clicking those buttons, we can add and remove an instance of another module. To make it simple, I have a toy example that has a simple module that just has a selectInput() IU with 3 choices. I want to be able to add as many of these selectInput() UI elements as desired and be able to access the results of these selections for use in the main server logic. So I created "firstUI()" and firstServer()" modules, as well as "addRmBtnUI()" and "addRmBtnServer()" modules. The addRmBtn modules accept parameters serverModToCall and uiModToCall, which are the names of the ui and server modules that we want to call with the addRmBtn modules. I seem to be getting tripped up on the passing of these modules as parameters to the addRmBtn modules. Code is below. How can I get this to work as intended? Thanks!
suppressWarnings(library(shiny))
firstUI <- function(id) {
ns <- NS(id)
tags$div(
fluidRow(
column(12,
uiOutput(ns("first"))
)
)
)
}
firstServer <- function(input, output, session) {
ns = session$ns
output$first <- renderUI({
selectInput(ns("select"), label = h4("Select"),
choices = list("Selection1" = 1, "Selection2" = 2,
"Selection3" = 3), selected = 1)
})
}
addRmBtnUI <- function(id) {
ns <- NS(id)
tags$div(
fluidRow(
column(2,
uiOutput(ns("insertParamBtn"))
),
column(2,
uiOutput(ns("removeParamBtn"))
)
),
hr(),
tags$div(id = 'placeholder')
)
}
addRmBtnServer <- function(input, output, session, serverModToCall, uiModToCall) {
ns = session$ns
params <- reactiveValues(btn = 0)
output$insertParamBtn <- renderUI({
actionButton(inputId = ns('insertParamBtn'),
label = "Add", offset = 3)
})
output$removeParamBtn <- renderUI({
actionButton(inputId = ns('removeParamBtn'),
label = "Remove", offset = 3)
})
params <- reactiveValues(btn = 0)
observeEvent(input$insertParamBtn, {
params$btn <- params$btn + 1
callModule(do.call(serverModToCall, args = list(id = params$btn)))
insertUI(
selector = '#placeholder',
ui = do.call(uiModToCall, args = list(id = params$btn)) #********# This line is issue
)
})
observeEvent(input$removeParamBtn, {
removeUI(
## pass in appropriate div id
selector = paste0('#param', params$btn)
)
params$btn <- params$btn - 1
})
}
ui <- function(request) {
fluidPage(
fluidRow(
addRmBtnUI(1)
),
fluidRow(
uiOutput("result")
)
)
}
server <- function(input, output, session) {
callModule(addRmBtnServer, id = 1,
serverModToCall = 'firstServer',
uiModToCall = 'firstUI')
res <- reactive({ })
output$result <- renderUI({
verbatimTextOutput(paste0(input[[NS(1, "select")]]), placeholder = T)
})
}
shinyApp(ui = ui, server = server)
It seems there were somme errors in the code
First, the call to firstServer was
callModule(do.call(firstServer, args = list(id = params$btn)))
which translates to
callModule(firstServer(params$btn))
callModule should however be invoked like this:
callModule(firstServer, params$btn)
The version below passes functions rather than function names, so the differences might be hard to spot at first glance.
Second, you need to namespace the ids for insertUI/removeUI. You can read more about this in the "nesting modules" section of this article.
## in addRmBtnServer/observe add button
insertUI(
selector = paste('#', ns('placeholder')),
ui = uiModToCall(ns(params$btn))
)
## in addRmBtnServer/observe remove button
removeFirstUI(ns(params$btn))
## in global scope
removeFirstUI <- function(id){
removeUI(selector = paste0('#', NS(id, "first") ))
}
Third, i am not sure what output$result was supposed to show, so I omitted it in the version below.
library(shiny)
firstUI <- function(id){uiOutput(NS(id, "first"))}
firstServer <- function(input, output, session){
output$first <- renderUI({
selectInput(session$ns("select"), h4("Select"), letters[1:4])
})
}
removeFirstUI <- function(id){
removeUI(selector = paste0('#', NS(id, "first")))
}
addRmBtnUI <- function(id) {
ns <- NS(id)
tags$div(
actionButton(inputId = ns('insertParamBtn'), label = "Add"),
actionButton(ns('removeParamBtn'), label = "Remove"),
hr(),
tags$div(id = ns('placeholder'))
)
}
addRmBtnServer <- function(input, output, session, moduleToReplicate) {
ns = session$ns
params <- reactiveValues(btn = 0)
observeEvent(input$insertParamBtn, {
params$btn <- params$btn + 1
callModule(moduleToReplicate$server, id = params$btn)
insertUI(
selector = paste0('#', ns('placeholder')),
ui = moduleToReplicate$ui(ns(params$btn))
)
})
observeEvent(input$removeParamBtn, {
moduleToReplicate$remover(ns(params$btn))
params$btn <- params$btn - 1
})
}
ui <- fluidPage(addRmBtnUI("addRm"))
server <- function(input, output, session) {
callModule(
addRmBtnServer, id = "addRm",
moduleToReplicate = list(
ui = firstUI,
server = firstServer,
remover = removeFirstUI
)
)
}
shinyApp(ui = ui, server = server)

R Shiny: How can I return reactive values from a shiny module to the master server function?

I have a simple toy example that uses an add/removeBtn module to add and remove UI from "first" module. I need to keep track of the number of times add/remove has been clicked. If I do not use modules, it is easy, but I am trying to do this in the context of nested modules. Code is below, but basically, I cannot seem to get access to the return from the addRmBtnServer() in the main server function. I am sure it is a simple fix, but I have tried many ways around this, but cannot seem to get access to the result from my call to addRmBtnServer(). Thanks!
library(shiny)
firstUI <- function(id) { uiOutput(NS(id, "first")) }
firstServer <- function(input, output, session, a) {
output$first <- renderUI({
selectInput(session$ns("select"), h4("Select"), paste0(isolate(a()),letters[1:4]))
})
}
removeFirstUI <- function(id) {
removeUI(selector = paste0('#', NS(id, "first")))
}
addRmBtnUI <- function(id) {
ns <- NS(id)
tags$div(
actionButton(inputId = ns('insertParamBtn'), label = "Add"),
actionButton(ns('removeParamBtn'), label = "Remove"),
hr(),
tags$div(id = ns('placeholder'))
)
}
addRmBtnServer <- function(input, output, session, moduleToReplicate, ...) {
ns = session$ns
params <- reactiveValues(btn = 0)
observeEvent(input$insertParamBtn, {
params$btn <- params$btn + 1
callModule(moduleToReplicate$server, id = params$btn, ...)
insertUI(
selector = paste0('#', ns('placeholder')),
ui = moduleToReplicate$ui(ns(params$btn))
)
})
observeEvent(input$removeParamBtn, {
moduleToReplicate$remover(ns(params$btn))
params$btn <- params$btn - 1
})
return(params$btn)
}
ui <- fluidPage(
addRmBtnUI("addRm"),
textInput("a", label = "a", value = 1, width = '150px'),
verbatimTextOutput("view", placeholder = TRUE)
)
server <- function(input, output, session) {
pars <- callModule(
addRmBtnServer, id = "addRm",
moduleToReplicate = list(
ui = firstUI,
server = firstServer,
remover = removeFirstUI
),
)
output$view <- renderText({ pars() })
}
shinyApp(ui = ui, server = server)
As said in the comment, you can pass the values as return values in the corresponding server functions. There is a working example below. I left out the firstUI, firstServer and removeFirstUI implementations since they are irrelevant for your problem.
library(shiny)
addRmBtnUI <- function(id) {
ns <- NS(id)
tags$div(
actionButton(inputId = ns('insertParamBtn'), label = "Add"),
actionButton(ns('removeParamBtn'), label = "Remove"),
hr(),
tags$div(id = ns('placeholder'))
)
}
addRmBtnServer <- function(input, output, session, moduleToReplicate, ...) {
ns = session$ns
params <- reactiveValues(btn = 0)
observeEvent(input$insertParamBtn, {
params$btn <- params$btn + 1
callModule(moduleToReplicate$server, id = params$btn, ...)
insertUI(
selector = paste0('#', ns('placeholder')),
ui = moduleToReplicate$ui(ns(params$btn))
)
})
observeEvent(input$removeParamBtn, {
moduleToReplicate$remover(ns(params$btn))
params$btn <- params$btn - 1
})
return(reactive({params$btn}))
}
ui <- fluidPage(
addRmBtnUI("addRm"),
verbatimTextOutput("view", placeholder = TRUE)
)
server <- function(input, output, session) {
a <- reactive({input$a})
pars <- callModule(
addRmBtnServer, id = "addRm",
moduleToReplicate = list(
ui = function(...){},
server = function(...){},
remover = function(...){}
)
)
output$view <- renderText({ pars() })
}
shinyApp(ui = ui, server = server)

Dynamic number of actionButtons tied to unique observeEvent

I'd like to generate a dynamic number of actionButtons, and then have each generated button print its number to the console. This is my best attempt so far, but I still can't get the observeEvent for each of the first 10 buttons to recognize the button clicks. How do I tie the buttons to an observeEvent?
library(shiny)
ui <- basicPage(
fluidRow(
actionButton(inputId = "add_button",
label = "Add Button")
),
uiOutput("more_buttons")
)
server <- function(input, output){
rvs <- reactiveValues(buttons = list(actionButton(inputId = "button1",
label = 1)))
observeEvent(eventExpr = input$add_button,
handlerExpr = {
len <- length(rvs$buttons) + 1
rvs$buttons[[len]] <- actionButton(inputId = paste0("button",len),
label = len)
})
output$more_buttons <- renderUI({
do.call(fluidRow, rvs$buttons)
})
# This is the part that doesn't work
for(ii in 1:10){
observeEvent(eventExpr = input[[paste0("button",ii)]],
handlerExpr = print(ii))
}
}
shinyApp(ui, server)
Your really close, just wrap the observeEvent part in local.
library(shiny)
ui <- basicPage(
fluidRow(
actionButton(inputId = "add_button",
label = "Add Button")
),
uiOutput("more_buttons")
)
server <- function(input, output){
rvs <- reactiveValues(buttons = list(actionButton(inputId = "button1",
label = 1)))
observeEvent(eventExpr = input$add_button,
handlerExpr = {
len <- length(rvs$buttons) + 1
rvs$buttons[[len]] <- actionButton(inputId = paste0("button",len),
label = len)
})
output$more_buttons <- renderUI({
do.call(fluidRow, rvs$buttons)
})
observeEvent(rvs$buttons,{
for(ii in 1:length(rvs$buttons)){
local({
i <- ii
observeEvent(eventExpr = input[[paste0("button",i)]],
handlerExpr = {print(sprintf("You clicked btn number %d",i))})
})
}
})
}
shinyApp(ui, server)
Let the inputIds of the buttons to follow a pattern like "button1", "button2", "button3", use regex to isolate those inputIds from the 'input' object in the observeEvent trigger, and convert the result to a list:
observeEvent(
lapply(
names(input)[grep("button[0-9]+",names(input))],
function(name){
input[[name]]
}
),
{
code to run when any button with inputId matching the regex is pressed
}
)

Resources