Value not updated in shiny using DT and drop-down selection

Question

I am trying to edit dynamically a data.frame using a Shiny App. The table describes a project's experiment structure and will thus include variable experimental factors, each with variable levels. For multi-level factors, I would like to allow value selection from a drop-down menu. For practical reasons, I want users to also be able to edit the table in Excel/any other table editor, so will be saving it as csv too. So the App should:

• Reload the local csv table,
• Create in the appropriate cells drop-down selections for factors using allowed values (factor levels),
• Also allow manual editing of values in other columns,
• When the "Save" button is clicked, the app should save the updated csv table then close However, while manual edits are saved as expected, as demonstrated in the example below, drop-down selection does not work.

require(shiny)
require(DT)

# Prepare mock data
wd <- getwd()
Factors <- c("Experiment", "Condition", "Replicate", "Genotype")
ExpMapNm <- "Experiment map"
ExpMapPath <- paste0(wd, "/", ExpMapNm, ".csv")
ExpMap <- data.frame(Experiment = "Exp1",
                     Sample = paste0("Sample", 1:20),
                     Condition = as.character(sapply(c("Treated", "Mock"), function(x) { rep(x, 10) })),
                     Genotype = as.character(sapply(c("KO", "WT"), function(x) { rep(x, 5) })),
                     Replicate = 1:5)
FactorsList <- setNames(lapply(Factors, function(x) { unique(ExpMap[[x]]) }), Factors)
#
# Users should be able to edit this table in two ways:
# - in Excel manually, hence why a local version is saved below and in server when closing the app
# - within the Shiny app
# In either case, the edited table will then be reloaded into r as a data.frame which will guide further data processing
if (!file.exists(ExpMapPath)) { write.csv(ExpMap, ExpMapPath, row.names = FALSE) }

ui <- shiny::fluidPage(shiny::titlePanel(ExpMapNm), # This is the name of the table
                       shiny::mainPanel(shiny::br(),
                                        shiny::actionButton("saveBtn", "Save"),
                                        DT::dataTableOutput("Data"),
                                        verbatimTextOutput(Factors)
                       ))
server <- function(input, output) {
  Data <- read.csv(ExpMapPath)
  for (Fact in Factors) {
    if (length(FactorsList[[Fact]]) > 1) { # We only want to have a drop-down selection if a factor has more than one level.
      # Thus, in this example we do not create a drop-down selection for factor Experiment.
      lvls <- FactorsList[[Fact]] # Allowed values
      for (i in 1:nrow(Data)) {
        val <- Data[[Fact]][i]
        dflt <- c(lvls[1], val)[(val %in% lvls)+1] # If the current value is not a valid level, revert to default (1st) level
        # Otherwise keep current value, but still apply drop-down selection so choices can be changed
        Data[[Fact]][i] <- as.character(selectInput(paste0(Fact, "_", i), NULL, lvls, dflt, width = "100px"))
      }
    } else { Data[[Fact]] <- FactorsList[[Fact]] }
  }
  output$Data <- DT::renderDataTable(
    Data, escape = FALSE, selection = "none", server = FALSE,
    editable = TRUE, # Non-drop-down fields can still be edited: this works
    options = list(paging = TRUE, searching = TRUE, fixedColumns = TRUE, autoWidth = TRUE,
                   ordering = TRUE, dom = "Bfrtip"),
    callback = JS("table.rows().every(function(i, tab, row) {
        var $this = $(this.node());
        $this.attr('id', this.data()[0]);
        $this.addClass('shiny-input-container');
      });
      Shiny.unbindAll(table.table().node());
      Shiny.bindAll(table.table().node());"),
    class = "display")
  shiny::observeEvent(input$Data_cell_edit, {
    Data[input$Data_cell_edit$row, input$Data_cell_edit$col] <<- input$Data_cell_edit$value
  })
  shiny::observeEvent(input$saveBtn, {
    # Hacky HTML cleanup
    # I am not interested in getting cells with html formatting in my table, I just want the value!
    # Moreover, this would clash with the code above when initiliazing the table and comparing values.
    #print(Data$Condition[[1]])
    for (Fact in Factors) {
      if (length(FactorsList[[Fact]]) > 1) {
        for (i in 1:nrow(Data)) {
          val <- Data[[Fact]][i]
          val <- gsub("^option value=\"[^\"]+\" selected>", "",
                      grep("^option value=\"[^\"]+\" selected>", unlist(strsplit(a, " *<|>[\n ]*<|> *$")), value = TRUE))
          Data[[Fact]][i] <- val
        }
      }
    }
    # Check if I have managed to change from the default value:
    print(Data$Condition[[1]])
    # When testing, I change from "Treated" to "Mock" in the table, hit save, but it prints "Treated", and sure enough the table saved contains "Treated".
    #
    write.csv(Data, ExpMapPath, row.names = FALSE)
    tstExpMap <<- Data # Another way to check table values
    stopApp()
  })
}
print(shiny::shinyApp(ui, server, options = list(launch.browser = TRUE)))

> sessionInfo()
R version 4.2.3 (2023-03-15 ucrt)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows Server x64 (build 20348)

Matrix products: default

locale:
[1] LC_COLLATE=English_United Kingdom.utf8  LC_CTYPE=English_United Kingdom.utf8    LC_MONETARY=English_United Kingdom.utf8
[4] LC_NUMERIC=C                            LC_TIME=English_United Kingdom.utf8    

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
[1] DT_0.26     shiny_1.7.4

loaded via a namespace (and not attached):
 [1] Rcpp_1.0.9        rstudioapi_0.14   magrittr_2.0.3    xtable_1.8-4      R6_2.5.1          rlang_1.0.6       fastmap_1.1.0     tools_4.2.3      
 [9] aRmel_4.0.0.13    cli_3.5.0         jquerylib_0.1.4   htmltools_0.5.4   crosstalk_1.2.0   ellipsis_0.3.2    yaml_2.3.6        digest_0.6.31    
[17] lifecycle_1.0.3   crayon_1.5.2      later_1.3.0       sass_0.4.4        htmlwidgets_1.6.0 promises_1.2.0.1  memoise_2.0.1     cachem_1.0.6     
[25] mime_0.12         compiler_4.2.3    bslib_0.4.2       jsonlite_1.8.4    httpuv_1.6.7

I have looked at many similar posts on StackOverflow, such as https://github.com/ejbeaty/CellEdit/tree/master/js, DT: Dynamically change column values based on selectinput from another column in R shiny app and Edit datatable in shiny with dropdown selection (for DT v0.19), which I based this app on actually, but I must be missing something as it just isn't working for me. Unfortunately, I know nothing about JavaScript so it is very difficult for me to figure out what is missing.

Fibroin

My post you linked above already provides the answer. You need to maintain two tables one is displayed as a DataTable including the dropdowns (displayTbl) and the other one holds the "raw" values (resultTbl) - you did not follow this concept. It could be done in a single table hiding the data columns, but I guess the "two tables"-approach is simpler. – Iridissa

My apologies and heartfelt thanks: I had tried your answer from that post, but clearly had made a mistake somewhere. Your solution works almost perfectly, with still one small issue: I also wanted non drop-down cells to be editable. This should be doable by adding editable = TRUE, then shiny::observeEvent(input$displayHTMLDF_cell_edit, {... }) (I might struggle a bit to make sure I have the right tables). However, if I set editable = TRUE, then make a manual change in a cell, as soon as I select a value from a drop-down selection, the former change is reverted. – Fibroin

I currently can't test it, but you might need to repeat editable = TRUE in the replaceData calls (just as I did with rownames = FALSE. Regarding the different tables: I'm sure this can be further simplified - I was short on time. Maybe I'll revise the code in the near future. Cheers – Iridissa

Answer 1

The following is a modified (generalized) version of my answer here, which reads in the csv file and allows to save it back to disk.

library(DT)
library(shiny)

# Prepare mock data
wd <- getwd()
Factors <- c("Experiment", "Condition", "Replicate", "Genotype")
ExpMapNm <- "dummy_data"
ExpMapPath <- paste0(wd, "/", ExpMapNm, ".csv")
ExpMap <- data.frame(Experiment = "Exp1",
                     Sample = paste0("Sample", 1:20),
                     Condition = as.character(sapply(c("Treated", "Mock"), function(x) { rep(x, 10) })),
                     Genotype = as.character(sapply(c("KO", "WT"), function(x) { rep(x, 5) })),
                     Replicate = 1:5)
FactorsList <- setNames(lapply(Factors, function(x) { unique(ExpMap[[x]]) }), Factors)

if (!file.exists(ExpMapPath)) { write.csv(ExpMap, ExpMapPath, row.names = FALSE) }

ui <- fluidPage(
  shiny::actionButton("saveBtn", "Save"),
  DT::dataTableOutput(outputId = 'my_table'),
)

server <- function(input, output, session) {
  
  resultDF <- displayHTMLDF <- initHTMLDF <- initData <- read.csv(ExpMapPath)
  
  dropdownCols <- names(initData)[3:5]
  dropdownIDs <- setNames(lapply(dropdownCols, function(x){paste0(x, seq_len(nrow(initData)))}), dropdownCols)
  
  for(dropdownCol in dropdownCols){
    colDropdownIDs <- dropdownIDs[[dropdownCol]]
    initHTMLDF[[dropdownCol]] <- sapply(seq_along(colDropdownIDs), function(i){as.character(selectInput(inputId = colDropdownIDs[i], label = "", choices = unique(initData[[dropdownCol]]), selected = initData[[dropdownCol]][i]))})
  }
  
  reactiveHTMLDF <- reactive({
    for(dropdownCol in dropdownCols){
      colDropdownIDs <- dropdownIDs[[dropdownCol]]
      displayHTMLDF[[dropdownCol]] <- sapply(seq_along(colDropdownIDs), function(i){as.character(selectInput(inputId = colDropdownIDs[i], label = "", choices = unique(initData[[dropdownCol]]), selected = input[[colDropdownIDs[i]]]))})
    }
    return(displayHTMLDF)
  })
  
  reactiveResultDF <- reactive({
    for(dropdownCol in dropdownCols){
      colDropdownIDs <- dropdownIDs[[dropdownCol]]
      resultDF[[dropdownCol]] <- sapply(seq_along(colDropdownIDs), function(i){input[[colDropdownIDs[i]]]})
    }
    return(resultDF)
  })
  
  output$my_table = DT::renderDataTable({
    DT::datatable(
      initHTMLDF, escape = FALSE, selection = 'none', rownames = FALSE,
      options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
                     preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                     drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
      )
    )
  }, server = TRUE)
  
  my_table_proxy <- dataTableProxy(outputId = "my_table", session = session)
  
  observeEvent({sapply(unlist(dropdownIDs), function(x){input[[x]]})}, {
    replaceData(proxy = my_table_proxy, data = reactiveHTMLDF(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
  }, ignoreInit = TRUE)
  
  shiny::observeEvent(input$saveBtn, {
    write.csv(reactiveResultDF(), ExpMapPath, row.names = FALSE)
    stopApp()
  })
}

shinyApp(ui = ui, server = server)

You might need to adapt a few things back to your needs, however, they were not needed to show the principle.

Iridissa

Answer 2

I think I solved it now, thanks a lot ismirsehregal!

To clarify my original issue:

• Multi-level Factor (Fact2) columns should be drop-down selections.
• Non-factor (Others) columns should allow free cell editing. (The code below it is a bit more complicated because I also hard over-write eventual manual edits in cells for single level factors, or Fact1.)

The issue with the proposed solution was that any choice from multi-level factor columns reverted any prior free edits to Others. In order to solve this, I rewrote the code so that, after the type of editing allowed in each column is defined, both are handled by the same lines of code.

library(DT)
library(shiny)

# Prepare mock data
wd <- getwd()
Factors <- c("Experiment", "Condition", "Replicate", "Genotype")
ExpMapNm <- "dummy_data"
ExpMapPath <- paste0(wd, "/", ExpMapNm, ".csv")
ExpMap <- data.frame(Experiment = "Exp1",
                     Sample = paste0("Sample", 1:20),
                     Condition = as.character(sapply(c("Treated", "Mock"), function(x) { rep(x, 10) })),
                     Genotype = as.character(sapply(c("KO", "WT"), function(x) { rep(x, 5) })),
                     Replicate = 1:5)
FactorsList <- setNames(lapply(Factors, function(x) { unique(ExpMap[[x]]) }), Factors)

if (!file.exists(ExpMapPath)) { write.csv(ExpMap, ExpMapPath, row.names = FALSE) }

ui <- fluidPage(
  shiny::titlePanel(ExpMapNm), # This is the name of the table
  shiny::mainPanel(shiny::br(),
                   shiny::actionButton("saveBtn", "Save"),
                   DT::dataTableOutput('my_table'))
)
server <- function(input, output, session) {
  initData <- read.csv(ExpMapPath)
  
  tst <- sapply(FactorsList, length)
  Fact1 <- Factors[which(tst == 1)]
  Fact2 <- Factors[which(tst > 1)]
  Others <- colnames(initData)[which(!colnames(initData) %in% Factors)]
  Editables <- c(Others, Fact2)
  nr <- nrow(initData)
  OtherIDs <- setNames(lapply(Others, function(x) { paste0(x, seq_len(nr))} ), Others)
  Fact2IDs <- setNames(lapply(Fact2, function(x) { paste0(x, seq_len(nr))} ), Fact2)
  AllIDs <- append(OtherIDs, Fact2IDs)
  for (Fact in Fact1) {
    # (Since the table can be manually edited too, we want to make sure to correct any typos in our single level factor columns)
    initData[[Fact]] <- FactorsList[[Fact]]
  }
  # ... before creating 3 copies of that datatable:
  resultDF <- displayHTMLDF <- initHTMLDF <- initData
  # initHTMLDF
  for (Oth in Others) {
    IDs <- OtherIDs[[Oth]]
    initHTMLDF[[Oth]] <- sapply(seq_along(IDs), function(i) {
      val <- initData[[Oth]][i]
      return(as.character(textInput(IDs[i], "", val)))
    })
  }
  for (Fact in Fact2) {
    IDs <- Fact2IDs[[Fact]]
    lvls <- FactorsList[[Fact]]
    initHTMLDF[[Fact]] <- sapply(seq_along(IDs), function(i) {
      val <- initData[[Fact]][i]
      dflt <- c(NA, val)[(val %in% lvls)+1] # If the current value is not a valid level, revert to NA
      return(as.character(selectInput(IDs[i], "", c(lvls, NA), dflt)))
    })
  }
  # displayHTMLDF
  reactiveHTMLDF <- reactive({
    for (Col in Editables) {
      IDs <- AllIDs[[Col]]
      if (Col %in% Others) {
        displayHTMLDF[[Col]] <- sapply(seq_along(IDs), function(i) {
          val <- initData[[Col]][i]
          return(as.character(textInput(IDs[i], "", input[[IDs[i]]])))
        })  
      } else {
        lvls <- FactorsList[[Col]]
        displayHTMLDF[[Col]] <- sapply(seq_along(IDs), function(i) { as.character(selectInput(IDs[i], "", lvls, input[[IDs[i]]])) })
      }
    }
    return(displayHTMLDF)
  })
  # resultDF
  reactiveResultDF <- reactive({
    for (Col in Editables) {
      IDs <- AllIDs[[Col]]
      resultDF[[Col]] <- sapply(seq_along(IDs), function(i) { input[[IDs[i]]] })
    }
    return(resultDF)
  })
  # Let's make sure we explicitly link row.names in multiple calls below 
  rwNms <- FALSE
  #
  output$my_table = DT::renderDataTable({
    DT::datatable(
      initHTMLDF, escape = FALSE, selection = "none", rownames = rwNms,
      editable = list(target = "cell", disable = list(columns = match(Fact1, colnames(initData))-1)), # Factors with 1 level should not be editable; indices appear to start at 0 (JS convention?)
      options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
                     preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                     drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
      )
    )
  }, server = TRUE)
  my_table_proxy <- dataTableProxy("my_table", session)
  observeEvent({ sapply(unlist(AllIDs), function(x) { input[[x]] }) }, {
    replaceData(proxy = my_table_proxy, data = reactiveHTMLDF(), rownames = rwNms) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
  }, ignoreInit = TRUE)
  shiny::observeEvent(input$saveBtn, {
    write.csv(reactiveResultDF(), ExpMapPath, row.names = FALSE)
    stopApp()
  })
}
print(shiny::shinyApp(ui, server, options = list(launch.browser = TRUE)))

Fibroin