How to add checkbox in datatable in a shiny module?

Question

I have a shiny module that displays a table with a comment column where users can input text on the client side and the comments then get stored in the database. Now, I want to add another column with checkboxes and store their corresponding values(TRUE/FALSE) in the database. Not sure how to retrieve checkbox values from the table. Below is my attempt on a sample data.

library(tidyverse)
library(shinyWidgets)
library(shiny)
library(htmlwidgets)


mtcars_df <- mtcars %>% 
  rownames_to_column(var="car")


writeback_UI <- function (id) {
  ns <- NS(id)

  DT::dataTableOutput(ns('records_tbl'))
  
}
shinyInput = function(FUN, len, id, ...) {
  inputs = character(len)
  for (i in seq_len(len)) {
    inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...))
  }
  inputs
}

# obtain the values of inputs
shinyValue = function(id, len) {
  unlist(lapply(seq_len(len), function(i) {
    value = input[[paste0(id, i)]]
    if (is.null(value)) NA else value
  }))
}




writeback_server <- function (id,records_data) {
  #stopifnot(is.reactive(records_data))
  shiny::moduleServer(id, function (input,output,session) {
    
    
    #initiate a reactive variable for storing comments
    comments_df <- reactiveVal(tibble(car=rownames(mtcars),comments=NA_character_))
    
    records_df <- reactive({
      records_data %>% 
        left_join(comments_df()) %>% 
        mutate(key_check= shinyInput(checkboxInput,nrow(.), 'cb_', value = TRUE))
        #mutate(check_values=shinyValue('cb_', nrow(.)))
    })
    
  

    

    
    
    
    output$records_tbl <- DT::renderDT({
      num_cols <- dim(records_df())[2]-2
      DT::datatable(
        records_df(),
        editable = list(target="column",disable=list(columns= 1:num_cols)),
        filter = "top",
        escape = FALSE,
        selection = 'none',
        options = list(
          dom = 't',
          paging = TRUE,
          ordering = FALSE,
          preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
          drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '),
          pageLength = 10,
          scrollX=TRUE,
          buttons=c('copy','csv','excel')),
        
      )
    }
    )
    
    
    observe({
      req(input$records_tbl_cell_edit)
      comments_data <- records_df() %>% 
        slice(input$records_tbl_cell_edit$row) %>% 
        select(car) %>% 
        mutate(comment=input$records_tbl_cell_edit$value) %>% 
        filter(comment!="")
      
      
      comments_df(comments_df() %>% 
                    rows_upsert(comments_data) %>% 
                    distinct())
      
  
    }) %>% 
      bindEvent(input$records_tbl_cell_edit)
    
    

    
    
   
    
    
    return(
      reactive({records_data %>%
          left_join(comments_df())
      }))
    
    # 
  }
  )
}


WriteBackTestApp <- function() {
  
  mtcars_df <- mtcars %>% rownames_to_column(var = "car")
  
  ui <- fluidPage(
    writeback_UI("wb")
  )
  
  server <- function(input, output, session) {
    writeback_server("wb",mtcars_df)
  }
  shinyApp(ui, server)
}

WriteBackTestApp()

Answer 1

Like this? (I don't see any problem regarding the module)

library(shiny)
library(DT)

ui <- fluidPage(
  br(),
  fluidRow(
    column(
      6,
      DTOutput("dtable")
    ),
    column(
      6,
      verbatimTextOutput("reactiveDF")
    )
  )
)

shinyInput <- function(FUN, len, id, ...) {
  inputs <- character(len)
  for (i in seq_len(len)) {
    inputs[i] <- as.character(FUN(paste0(id, i), label = NULL, ...))
  }
  inputs
}

dat0 <- data.frame(
  fruit  = c("apple", "cherry", "pineapple", "pear"),
  letter = c("a", "b", "c", "d")
)

dat1 <- cbind(dat0, bool = FALSE)

dat2 <- cbind(
  dat0,
  check = shinyInput(checkboxInput, nrow(dat0), "checkb")
)

js <- c(
  "$('[id^=checkb]').on('click', function(){",
  "  var id = this.getAttribute('id');",
  "  var i = parseInt(/checkb(\\d+)/.exec(id)[1]);",
  "  var value = $(this).prop('checked');",
  "  var info = [{row: i, col: 3, value: value}];",
  "  Shiny.setInputValue('dtable_cell_edit:DT.cellInfo', info);",
  "})"
)

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

  Dat <- reactiveVal(dat1)

  output[["dtable"]] <- renderDT({
    datatable(
      dat2, 
      rownames = TRUE,
      escape = FALSE,
      editable = list(target = "cell", disable = list(columns = 3)),
      selection = "none",
      callback = JS(js)
    )
  }, server = FALSE)

  observeEvent(input[["dtable_cell_edit"]], { 
    info <- input[["dtable_cell_edit"]] # this input contains the info of the edit
    print(info)
    Dat(editData(Dat(), info))
  })
  
  output[["reactiveDF"]] <- renderPrint({ 
    Dat()
  })

}

shinyApp(ui, server)

---

EDIT: with a module

library(shiny)
library(DT)

shinyInput <- function(FUN, len, id, ...) {
  inputs <- character(len)
  for (i in seq_len(len)) {
    inputs[i] <- as.character(FUN(paste0(id, i), label = NULL, ...))
  }
  inputs
}

dat0 <- data.frame(
  fruit  = c("apple", "cherry", "pineapple", "pear"),
  letter = c("a", "b", "c", "d")
)

dat1 <- cbind(dat0, bool = FALSE)

dat2 <- cbind(
  dat0,
  check = shinyInput(checkboxInput, nrow(dat0), "checkb")
)

js <- function(dtid, ns) {
  c(
    "$('[id^=checkb]').on('click', function(){",
    "  var id = this.getAttribute('id');",
    "  var i = parseInt(/checkb(\\d+)/.exec(id)[1]);",
    "  var value = $(this).prop('checked');",
    "  var info = [{row: i, col: 3, value: value}];",
    sprintf(
      "Shiny.setInputValue('%s', info);",
      ns(sprintf("%s_cell_edit:DT.cellInfo", dtid))
    ),
    "})"
  )
}


tableUI <- function(id) {
  ns <- NS(id)
  fluidRow(
    column(
      6,
      DTOutput(ns("dtable"))
    ),
    column(
      6,
      verbatimTextOutput(ns("reactiveDF"))
    )
  )
}

tableServer <- function(id) {
  moduleServer(id, function(input, output, session) {
    Dat <- reactiveVal(dat1)

    output[["dtable"]] <- renderDT(
      {
        datatable(
          dat2,
          rownames = TRUE,
          escape = FALSE,
          editable = list(target = "cell", disable = list(columns = 3)),
          selection = "none",
          callback = JS(js("dtable", session$ns))
        )
      },
      server = FALSE
    )

    observeEvent(input[["dtable_cell_edit"]], {
      info <- input[["dtable_cell_edit"]]
      Dat(editData(Dat(), info))
    })

    output[["reactiveDF"]] <- renderPrint({
      Dat()
    })
  })
}


ui <- fluidPage(
  br(),
  tableUI("xxx")
)

server <- function(input, output, session) {
  tableServer("xxx")
}

shinyApp(ui, server)

---

EDIT: multiple pages

If there is more than one page, replace

js <- function(dtid, ns) {
  c(
    "$('[id^=checkb]').on('click', function(){",
    "  var id = this.getAttribute('id');",
    "  var i = parseInt(/checkb(\\d+)/.exec(id)[1]);",
    "  var value = $(this).prop('checked');",
    "  var info = [{row: i, col: 3, value: value}];",
    sprintf(
      "Shiny.setInputValue('%s', info);",
      ns(sprintf("%s_cell_edit:DT.cellInfo", dtid))
    ),
    "})"
  )
}

with

js <- function(dtid, ns) {
  c(
    "$('body').on('click', '[id^=checkb]', function(){",
    "  var id = this.getAttribute('id');",
    "  var i = parseInt(/checkb(\\d+)/.exec(id)[1]);",
    "  var value = $(this).prop('checked');",
    "  var info = [{row: i, col: 3, value: value}];",
    sprintf(
      "Shiny.setInputValue('%s', info);",
      ns(sprintf("%s_cell_edit:DT.cellInfo", dtid))
    ),
    "})"
  )
}