rshinydt

How to save datatable content when a SelectInput in a cell is updated?


I'm looking for a way to display Statut as inputSelect taking c('','yes','no', 'refused') and Commentaires taking c('','b','c','d') and when a person changes it to something different than '', to save the new value on a .csv. It saves a simple input but not for a choice in a list.

library(DT)
library(htmltools)
library(shiny)
library(readr)

save_ref_values <- function(df, name) {
  write.csv(df, name, row.names = FALSE)  
}

missing_values <- structure(list(field_label = c("Date0:", "SR"),
    id = c("link","n"
    ), field = c("date1", "a"), value = c(NA,
    NA), form = c("eval 3", "eval 4"
    ), event = c("5", "5"), label = c("1",
    "1"), field_type = c("text", "radio"), required = c("y",
    "y"), logic = c(NA_character_, NA_character_),
    Commentaires = c(NA, NA), Statut = c(NA, NA)), row.names = 1:2, class = "data.frame")
 

datatableFactory <- function(df) {
  editable_columns <- which(names(df) %in% c("Statut", "Commentaires"))
  df$Statut <-  c(
        as.character(selectInput(
          inputId = "id1",
          label = NULL,
          choices = c('','yes','no', 'refused'),
        ))
      )
  df$Commentaires <-  c(
        as.character(selectInput(
          inputId = "id1",
          label = NULL,
          choices = c('','b','c','d')
        ))
      )
  values_dt_table <- DT::datatable(df,
                                     options = list(pageLength = 5, autoWidth = TRUE),
                                     filter = list(position = 'top', clear = FALSE),
                                     editable = list(target = "cell", disable = list(columns = setdiff(1:dim(df)[2], editable_columns))),
                                     escape = F)
  return(values_dt_table)
}

ui <- fluidPage(
  titlePanel("Génération du Rapport"),
  mainPanel(
  h2("Rapport Preview"),
  DTOutput("missing_values_dt_table"),
  )
)

update_table_data <- function(input, input_id, data_reactif, save_function) {
  observeEvent(input[[input_id]], {
    info <- input[[input_id]]
    i <- info$row 
    j <- info$col 
    value <- info$value 
    new_data <- data_reactif()
    if (colnames(new_data)[j] == "Commentaires") {
      new_data[i, "Commentaires"] <- value
    } else if (colnames(new_data)[j] == "Statut") {
      new_data[i, "Statut"] <- value
    }

    data_reactif(new_data)
    save_function(new_data)
  })
}
 
server <- function(input, output, session) {
missing_values <- read.csv("missing_values.csv")
missing_values_data <- reactiveVal(missing_values)
output$missing_values_dt_table <- renderDT({
datatableFactory(missing_values_data())
})
update_table_data(input
                   , "missing_values_dt_table_cell_edit"
                   , missing_values_data
                   , function(data) save_ref_values(data, "missing_values.csv"))
}

shinyApp(ui, server)  

Solution

  • In your app you already have a logic which triggers an observeEvent when the table data is changed ("missing_values_dt_table_cell_edit") and then writes the data to the .csv. So what we can try is to trigger the _cell_edit event if a value of one of the selectInput inside the datatable is changed.

    It can be done like so: Install observeEvents on all of the selectInputs and collect the corresponding row, column and value where the input has changed. Usesession$sendCustomMessage() and send this info to JS, and there trigger the already existing event by using Shiny.setInputValue('missing_values_dt_table_cell_edit', info);. And then we just do some smaller post-processing in R and write the .csv.

    enter image description here

    enter image description here

    library(DT)
    library(htmltools)
    library(shiny)
    library(readr)
    
    save_ref_values <- function(df, name) {
      write.csv(df, name, row.names = FALSE)  
    }
    
    missing_values <- structure(
      list(
        id = c("link", "n"), 
        Commentaires = sapply(1:2, function(i) as.character(selectInput(inputId = paste0("comm_", i), label=NULL, choices=c('','b','c', 'd')))),
        Statut = sapply(1:2, function(i) as.character(selectInput(inputId = paste0("statut_", i), label=NULL, choices=c('','yes','no', 'refused'))))
      ), row.names = 1:2, class = "data.frame"
    )
    
    
    datatableFactory <- function(df) {
      editable_columns <- which(names(df) %in% c("Statut", "Commentaires"))
      values_dt_table <- DT::datatable(df,
                                       rownames = FALSE,
                                       options = list(pageLength = 5, autoWidth = TRUE,
                                                      preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                                                      drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')),
                                       filter = list(position = 'top', clear = FALSE),
                                       editable = list(target = "cell", disable = list(columns = setdiff(1:dim(df)[2], editable_columns))),
                                       escape = F)
      return(values_dt_table)
    }
    
    ui <- fluidPage(
      tags$head(
        tags$script("
             Shiny.addCustomMessageHandler('triggerCellEdit', function(info) {
              Shiny.setInputValue('missing_values_dt_table_cell_edit', info);
            });       
        ")
      ),
      findDependencies(selectizeInput("dummy", label = NULL, choices = NULL)),
      titlePanel("Génération du Rapport"),
      mainPanel(
        h2("Rapport Preview"),
        DTOutput("missing_values_dt_table"),
      )
    )
    
    update_table_data <- function(input, input_id, data_reactif, save_function) {
      observeEvent(input[[input_id]], {
        info <- input[[input_id]]
        info <- list(row = info[[1]], col = info[[2]], value = info[[3]])
        i <- as.integer(info$row)
        j <- as.integer(info$col)
        value <- info$value
        req(value != "")
        new_data <- data_reactif()
        data_reactif(new_data)
        # special processing because we don't want to write the HTML
        save_data <- subset(new_data, select = -c(Statut, Commentaires))
        save_data$Commentaires <- sapply(1:nrow(missing_values), function(i) input[[paste0("comm_", i)]])
        save_data$Statut <- sapply(1:nrow(missing_values), function(i) input[[paste0("statut_", i)]])
        save_function(save_data)
      })
    }
    
    server <- function(input, output, session) {
    
      missing_values_data <- reactiveVal(missing_values)
    
      output$missing_values_dt_table <- renderDT({
        datatableFactory(missing_values_data())
      })
      
      sapply(1:nrow(missing_values), function(x) {
        sapply(c("statut_", "comm_"), function(colPre) {
          observeEvent(input[[paste0(colPre, x)]], {
            row <- x
            col <- grep(if (colPre == "statut_") "Statut" else "Commentaires", colnames(missing_values_data()))
            value <- input[[paste0(colPre, x)]]
            session$sendCustomMessage("triggerCellEdit", list(row, col, value))
          }, ignoreInit = TRUE)
        })
      })
    
      update_table_data(input
                        , "missing_values_dt_table_cell_edit"
                        , missing_values_data
                        , function(data) save_ref_values(data, "missing_values.csv"))
    
    }
    
    shinyApp(ui, server)