Get an input from a button in table from modules in R

Question

I'm starting to work with modules using Rhino, and I want to get the input from a button that is inside a table when it is clicked.

This is the module that creates the table and generate HTML buttons for each line item.

# app/logic/fluxogramaProcesso.R

box::use(
    glue[glue],
    dplyr[filter, select, mutate],
    reactable[reactable, colDef],
    DBI[dbConnect, dbDisconnect, dbGetQuery],
)

box::use(
    app/logic/connectdb,
    app/logic/funcTrim
)

#' @export
cadastroProdutos <- function() {
    con <- connectdb$create_con()
    
    produtos_query <- glue("SELECT ITEM_CODE FROM TABLE")
    
    produtos_tbl <- dbGetQuery(con, produtos_query) |>
        funcTrim$trimDataChar() |>
        as.data.frame() |>
        mutate(
            view_item = glue::glue('<button class="btn" id="vw_item" onclick="Shiny.onInputChange(\'vw_item\', \'{ITEM_CODE}\')"> <i class="fa-solid fa-eye"></i> </button>')
        ) |>
        reactable(
            columns = list(
                view_item = colDef(html = TRUE)
            )
        )
    
    dbDisconnect(con)
    
    return(produtos_tbl)
}

**The table generated by this module, goes to a module that generate the server and ui of this table. **

# app/view/table.R

box::use(
    reactable[reactableOutput, renderReactable],
    shiny[moduleServer, NS, observeEvent],
)

#' @export
ui <- function(id) {
    ns <- NS(id)
    reactableOutput(ns("table"))
}


#' @export
server <- function(id, data) {
    moduleServer(id, function(input, output, session){
        output$table <- renderReactable({
            data()
        })
    })
}

And then finnaly go to my main.R

# app/main.R

box::use(
    shiny[bootstrapPage, moduleServer, NS, reactive, icon, textInput, renderText, observeEvent, showModal, modalDialog],
    shinydashboard[dashboardPage, dashboardHeader, dashboardBody, dashboardSidebar, sidebarMenu, menuItem, tabItems, tabItem],
)

box::use(
    app/view/table,
    app/view/dataTable,
    app/logic/dataProduct,
    app/logic/fluxogramaProcesso,
    app/logic/cadastroProdutos,
)

#' @export
ui <- function(id) {
    ns <- NS(id)
    
    dashboardPage(
        dashboardHeader(),
        
        dashboardSidebar(
            sidebarMenu(
                menuItem("Fluxograma  de Processos", 
                         tabName = "fluxproc",
                         icon = icon("sitemap"))
            )
        ),
        
        dashboardBody(
            tabItems(
                tabItem(tabName  = "fluxproc",
          
                        table$ui(ns("cadastroProd"))
                        )
            )
        )
    )
}

#' @export
server <- function(id) {
    moduleServer(id, function(input, output, session) {
        
        dataProdutos <- reactive(cadastroProdutos$cadastroProdutos())
        table$server("cadastroProd", dataProdutos)
        
        observeEvent(input$vw_item, {
            showModal(
                modalDialog(
                    h2("IT WORKS !!!!")
                )
            )
        }
        )
    })
}

I would like to when the button on the table was clicked it generates for example a showModal. I couldn't retrieve the input from the button.

Answer 1

I'm not familiar with Rhino and box so I'm not sure of me.

This is a server module:

server <- function(id) {
    moduleServer(id, function(input, output, session) {
        
        dataProdutos <- reactive(cadastroProdutos$cadastroProdutos())
        table$server("cadastroProd", dataProdutos)
        
        observeEvent(input$vw_item, {
            showModal(
                modalDialog(
                    h2("IT WORKS !!!!")
                )
            )
        }
        )
    })
}

Therefore, if I'm not mistaken, the observer will actually listen to input[[ns("vw_item")]] and then the button click will never be detected because it triggers Shiny.onInputChange("vw_item".

So I would try:

cadastroProdutos <- function(ns) { # add ns argument
    con <- connectdb$create_con()
    
    produtos_query <- glue("SELECT ITEM_CODE FROM TABLE")
    
    ID <- ns("vw_item") # the name of the Shiny value sent on click

    produtos_tbl <- dbGetQuery(con, produtos_query) |>
        funcTrim$trimDataChar() |>
        as.data.frame() |>
        mutate( # send input[[ID]] on click
            view_item = glue::glue('<button class="btn" id="vw_item" onclick="Shiny.onInputChange(\'{ID}\', \'{ITEM_CODE}\')"> <i class="fa-solid fa-eye"></i> </button>')
        ) |>
        reactable(
            columns = list(
                view_item = colDef(html = TRUE)
            )
        )
    
    dbDisconnect(con)
    
    return(produtos_tbl)
}

and:

server <- function(id) {
    moduleServer(id, function(input, output, session) {
        ns <- session$ns
        
        dataProdutos <- reactive(cadastroProdutos$cadastroProdutos(ns)) # added ns
        table$server("cadastroProd", dataProdutos)
        
        observeEvent(input$vw_item, {
            showModal(
                modalDialog(
                    h2("IT WORKS !!!!")
                )
            )
        }
        )
    })
}

---

Edit: possible alternative

A possible alternative is to use the reactable.extras package to make the buttons. Unfortunately, I have not been able to render an icon inside these buttons (but I opened an issue on the reactable.extras Github repo about this problem).

library(shiny)
library(reactable)
library(reactable.extras)

df <- MASS::Cars93[, 1:4]
df$view_item <- "click"

mod_ui <- function(id) {
  ns <- NS(id)
  reactableOutput(ns("table"))
}

mod_server <- function(id) {
  moduleServer(
    id,
    function(input, output, session) {
      
      ns <- session$ns
      
      output$table <- renderReactable({
        reactable(
          df,
          columns = list(
            view_item = colDef(
              cell = button_extra(id = ns("button"), class = "button-extra")
            )
          )
        )
      })
      
      item <- eventReactive(input$button, {
        df$Manufacturer[input$button$row]
      })
      
      return(item)
    }
  )
}

ui <- fluidPage(
  reactable_extras_dependency(),
  mod_ui("x")
)


server <- function(input, output, session) {

  x <- mod_server("x")
  
  observe({
    print(x())
  })
  
}

shinyApp(ui, server)