R Shiny modules using purrr::map to dynamically make buttons -- how to dynamically create observers to use these button inputs

Question

I am new to functional programming with purrr. There is probably a sweet solution out there in purrr for this. I generate UI buttons with namespaced IDs same as the record IDs in a dataframe. I generate an observer for each button. I cannot figure out how to make use of the button click events. Ideally, I would like the button click to return the corresponding record to take elsewhere. I am so far trying to extract the button id when it is clicked. The observeEvents I create dynamically, so no way of knowing the button ID in advance...I mean, I can see it in the HTML, but I need to have it returned somehow so I can act on the corresponding dataframe record. My simplified reproducible app is below. In the map() function where I generate the observeEvents, I have tried to print to console various things trying to get the button ID. I have tried an extra

onclick = "Shiny.onInputChange('thisClick', this.id)"

within the actionButton. This works in a Shiny app as 'thisClick' is then an object in input. But in a module context, it does not get created, or gets destroyed. Any and all help is greatly appreciated!

Reporducibile Code:

library(shiny)
library(tidyverse)
meals <- data.frame(
MEAL_ID = c(1,2,3,4,5,6),
MEAL_TYPE = c('Breakfast','Breakfast','Lunch','Lunch','Dinner','Dinner'),
MEAL = c('Lox and Bagels','Eggs to Order', 'Pita Sandwiches', 'Chicken Cesar Wraps', 'Lasagna','Steak Dinner'),
DESCRIPTION = c('Delicious lox and bagels.',
                'Eggs with potatoes and fruit',
                'Pita with cold cuts and cookies',
                'Chicken cesar salad in tortillas',
                'Dutch overn lasagna with salad and breadsticks.',
                'Steak with potatoes and salad.')
)
mealCard <- function(session,id, ttl, subttl, desc){
ns <- session$ns
div(id = ns(id), class='card',
    div(class='card-body',
        h5(class='card-title', ttl),
        h6(class='card-subtitle mb-2 text-muted', subttl),
        p(class='card-text', desc),
        actionButton(inputId = ns(paste0('add-',id)),label = 'Add',onclick =
                         "Shiny.onInputChange('thisClick1',this.id)")
    )
)
}

testUI <- function(id) {
ns <- NS(id)
tagList(
  actionButton(ns('dummy'),'Dummy', onclick =
                   "Shiny.onInputChange('thisClick2',this.id)"),
  uiOutput(ns('test')),
  )
}

testServer <- function(id,data) {
moduleServer(id, function(input, output, session) {
    meals <- data
  
    output$test <- renderUI({
        #browser()
        ids <- meals %>% pull(MEAL_ID)
        addButtonIDs <- meals %>% pull(MEAL_ID) %>% paste0('add-',.)
    
        #Make card button observers -- Problem Area
        map(addButtonIDs, ~ observeEvent(input[[.x]],{
            print(input$thisClick1) # Returns null -- this Shiny.onInputChange thing works if not in a module
            print(input[[.x]]) # Button attributes but no ID
            print(addButtonIDs[input[[.x]]]) # This is subsetting by the number of times the button has been clicked
            # id <- gsub('add-','',(input$thisClick)) -- this Shiny.onInputChange thing works if not in a module
            # print(meals %>% filter(MEAL_ID == id)) -- this Shiny.onInputChange thing works if not in a module
            # Need to be able to use the action buttons to do stuff!!
            })
        )
      
        #Make cards
        map(ids, ~ mealCard(session,meals[.,1],meals[.,3],NULL,meals[.,4])) 
    })
  
    observeEvent(input$dummy,{
        #browser()
        print(input$thisClick2) # Returns null -- this Shiny.onInputChange thing works if not in a module
    })
})
}

ui <- fluidPage(
testUI('test1')
)

server <- function(input, output, session) {
testServer('test1', data = meals)
}

shinyApp(ui, server)

Answer 1

I'm not sure what kind of operatiin you want to perform with a click on the action buttons, but using reactiveValues() can help to record the number of times a button has been clicked. With the solution below you should be able to trigger other actions as well.

library(shiny)
library(tidyverse)

meals <- data.frame(
  MEAL_ID = c(1,2,3,4,5,6),
  MEAL_TYPE = c('Breakfast','Breakfast','Lunch','Lunch','Dinner','Dinner'),
  MEAL = c('Lox and Bagels','Eggs to Order', 'Pita Sandwiches', 'Chicken Cesar Wraps', 'Lasagna','Steak Dinner'),
  DESCRIPTION = c('Delicious lox and bagels.',
                  'Eggs with potatoes and fruit',
                  'Pita with cold cuts and cookies',
                  'Chicken cesar salad in tortillas',
                  'Dutch overn lasagna with salad and breadsticks.',
                  'Steak with potatoes and salad.')
)

mealCard <- function(session, id, ttl, subttl, desc){
  ns <- session$ns
  div(id = ns(id), class='card',
      div(class='card-body',
          h5(class='card-title', ttl),
          h6(class='card-subtitle mb-2 text-muted', subttl),
          p(class='card-text', desc),
          actionButton(inputId = ns(paste0('add-',id)),
                       label = 'Add'# ,
                       # onclick = "Shiny.onInputChange('thisClick1',this.id)")
          )
      )
  )
}

testUI <- function(id) {
  ns <- NS(id)
  tagList(
    actionButton(ns('dummy'),'Dummy', onclick =
                   "Shiny.onInputChange('thisClick2',this.id)"),
    uiOutput(ns('test')),
  )
}

testServer <- function(id,data) {
  moduleServer(id, function(input, output, session) {
    
    # new: reactiveValues (a list)
    r <- reactiveValues()
    
    meals <- data
    
    output$test <- renderUI({
      #browser()
      ids <- meals %>% pull(MEAL_ID)
      addButtonIDs <- meals %>% pull(MEAL_ID) %>% paste0('add-',.)
      
      #Make card button observers -- Problem Area
      map(addButtonIDs, ~ observeEvent(input[[.x]],{
        # if sub-list is empty set it to one, otherwise take value and add 1
        if ( is.null(r[[.x]])) r[[.x]] <- 1L
        if (!is.null(r[[.x]])) r[[.x]] <- r[[.x]] + 1L
        
        print(input[[paste0("add-", id)]]) # Returns null -- this Shiny.onInputChange thing works if not in a module
        print(input[[.x]]) # Button attributes but no ID
        
      })
      )
      
      #Make cards
      map(ids, ~ mealCard(session, meals[.,1], meals[.,3], NULL, meals[.,4])) 
    })
    
    observeEvent(input$dummy,{
      #browser()
      print(input$thisClick2) # Returns null -- this Shiny.onInputChange thing works if not in a module
    })
  })
}

ui <- fluidPage(
  testUI('test1')
)

server <- function(input, output, session) {
  testServer('test1', data = meals)
}

shinyApp(ui, server)