rshinymodulereturn-valueobservers

r shiny how to use lapply with moduleServer that returns a reactive that I want to observe


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()

Solution

  • You can use lapply to create the module servers and the observers 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()
    

    enter image description here