I'm trying to simplify my code. Rather than copy/pasting similar elements, I want to define a list that describes them and then lapply to get them. I need two/way communication with a global setting.
Here's what I start with. I have a global numericInput
, and I have multiple modules that contain numericInput
. Changing the global propagates to the modules. Changing a module can be propagated to global by clicking a button. Once global is updated, this propagates to all modules:
library(shiny)
testUI <- function(id) {
tagList(
numericInput(NS(id, "module"), "module", value = NULL),
actionButton(NS(id,"button"), label = "send")
)
}
testServer <- function(id,reactinput) {
stopifnot(is.reactive(reactinput))
moduleServer(id, function(input,output,session) {
rval <- reactiveValues(num = NULL)
observe({rval$num <- reactinput()})
observeEvent(rval$num,{updateNumericInput(inputId = "module", value = rval$num)})
observeEvent(input$button, {
rval$num <- input$module
})
return(reactive({rval$num}))
})
}
testApp <- function() {
ui <- fluidPage(
numericInput("global", "global", value = 5),
testUI("test1"),
testUI("test2"),
testUI("test3")
)
server <- function(input, output, session) {
val1 <- testServer("test1",reactive(input$global))
observeEvent(val1(), {updateNumericInput(inputId = "global", value = val1())})
val2 <-testServer("test2",reactive(input$global))
observeEvent(val2(), {updateNumericInput(inputId = "global", value = val2())})
val3 <-testServer("test3",reactive(input$global))
observeEvent(val3(), {updateNumericInput(inputId = "global", value = val3())})
}
shinyApp(ui, server)
}
testApp()
That works. But, for real applications, and with large numbers of called modules, this is quickly not a lot of fun. I see that we can use lapply to generate the UI:
library(shiny)
itemlist <- list("test1", "test2", "test3")
testUI <- function(id) {
tagList(
numericInput(NS(id, "module"), "module", value = NULL),
actionButton(NS(id,"button"), label = "send")
)
}
testServer <- function(id,reactinput) {
stopifnot(is.reactive(reactinput))
moduleServer(id, function(input,output,session) {
rval <- reactiveValues(num = NULL)
observe({rval$num <- reactinput()})
observeEvent(rval$num,{updateNumericInput(inputId = "module", value = rval$num)})
observeEvent(input$button, {
rval$num <- input$module
})
return(reactive({rval$num}))
})
}
testApp <- function() {
ui <- fluidPage(
numericInput("global", "global", value = 5),
lapply(itemlist,testUI)
)
server <- function(input, output, session) {
val1 <- testServer("test1",reactive(input$global))
observeEvent(val1(), {updateNumericInput(inputId = "global", value = val1())})
val2 <-testServer("test2",reactive(input$global))
observeEvent(val2(), {updateNumericInput(inputId = "global", value = val2())})
val3 <-testServer("test3",reactive(input$global))
observeEvent(val3(), {updateNumericInput(inputId = "global", value = val3())})
}
shinyApp(ui, server)
}
testApp()
This still works. But of course, I want to also not copy/paste the server functions. It is beyond me how I would do that. I looked online, and at several posts. I think this thread is pretty close to what I want to do, but I fail to be able to figure out how to apply it in my situation. This thread has no answer. And I couldn't find any other posts about lapply with server functions that return a reactive. Perhaps I'm not using the right search terms. Most attempts didn't work at all. It at least stopped crashing when I did this:
server <- function(input, output, session) {
vallist <- reactive(lapply(itemlist,function(item) {testServer(item,
reactinput=reactive(input$global))}))
observeEvent(vallist(), {updateNumericInput(inputId = "global", value = vallist())}
}
but it's not working. I have been kicking myself, it must not be so hard as I am making it. Any help on how to call the server functions and observing the returned reactives would be appreciated.
EDIT: all right, this is fantastic! thanks for the help, @stefan!
with the help of the final edit of stefan, I found a way to change itemlist
into a list of lists. I have that in my real app code, so I can organize all the information that I want to pass to a more complex module.
so, for anyone running into a similar problem, here is the solution:
library(shiny)
#this time I use a list of lists in itemlist.
itemlist <- list(
list(name="test1",
stuff="other1"),
list(name="test2",
stuff="other2"),
list(name="test3",
stuff="other3")
)
testUI <- function(id) {
tagList(
numericInput(NS(id, "module"), "module", value = NULL),
actionButton(NS(id,"button"), label = "send")
)
}
testServer <- function(id,reactinput) {
stopifnot(is.reactive(reactinput))
moduleServer(id, function(input,output,session) {
rval <- reactiveValues(num = NULL)
observe({rval$num <- reactinput()})
observeEvent(rval$num,{updateNumericInput(inputId = "module", value = rval$num)})
observeEvent(input$button, {
rval$num <- input$module
})
return(reactive({rval$num}))
})
}
testApp <- function() {
ui <- fluidPage(
numericInput("global", "global", value = 5),
#here I apply the same approach as user stefan suggested for the server function (thanks!)
lapply(seq_along(itemlist), function(item) {
testUI(itemlist[[item]]$name)
})
)
server <- function(input, output, session) {
#and also here I apply it
vals <- lapply(seq_along(itemlist),function(item){
testServer(itemlist[[item]]$name,reactinput=reactive(input$global))
})
lapply(seq_along(itemlist), function(item){
observe({
updateNumericInput(inputId = "global", value = vals[[item]]())
})
})
}
shinyApp(ui, server)
}
testApp()
You can use lapply
to create the module servers and the observe
rs like so:
library(shiny)
itemlist <- list("test1", "test2", "test3")
testUI <- function(id) {
tagList(
numericInput(NS(id, "module"), "module", value = NULL),
actionButton(NS(id, "button"), label = "send")
)
}
testServer <- function(id, reactinput) {
stopifnot(is.reactive(reactinput))
moduleServer(id, function(input, output, session) {
rval <- reactiveValues(num = NULL)
observe({
rval$num <- reactinput()
})
observeEvent(rval$num, {
updateNumericInput(inputId = "module", value = rval$num)
})
observeEvent(input$button, {
rval$num <- input$module
})
return(reactive({
rval$num
}))
})
}
testApp <- function() {
ui <- fluidPage(
numericInput("global", "global", value = 5),
lapply(itemlist, testUI)
)
server <- function(input, output, session) {
vals <- lapply(itemlist, testServer, reactinput = reactive(input$global))
lapply(seq_along(itemlist), \(item) {
observe({
updateNumericInput(inputId = "global", value = vals[[item]]())
})
})
}
shinyApp(ui, server)
}
testApp()