Infinite loop when updating value on select cell in shiny DT::datatable

[Peter2]

Hi all,
I searched the web for while but could not solve this problem with shiny and DT: The aim is to update the value of cell in a datable when the user clicks on the corresponding cell. I observe() the "cells_selected" input of the table and call the corresponding function to update the value. The problem is that the function gets called in a infinite loop. Somehow, resetting the cell selection to NULL does not seem to work. See below for a minimal working example. Any hint is welcome!

library(shiny)
library(DT)

ui <- fluidPage(
  #A minimal GUI
  mainPanel(
    DT::dataTableOutput("DemoTable")
  )
)


server <- function(input, output) {

  #A reactive data frame with some initialization  
  DemoTable <- data.frame(
    value1 = runif(0,1,n=4),
    value2 = runif(0,1,n=4)
  )
  makeReactiveBinding("DemoTable")
  
  #Link the demo table reactive to the output datatable
  output$DemoTable = DT::renderDataTable({
    MyDT <- datatable(data=DemoTable,selection=list(mode="single",target="cell"))
    return(MyDT)
  })
  
  
  #A function to change the value in the selected cell
  UpdateValue <- function(row,col) {
    tmp <- DemoTable
    tmp[row,col] <- runif(0,1,n=1)
    DemoTable <<- tmp
  }
  
  
  #Observe cell select event of table
  AnyCellSelected <- reactive({!is.null(input$DemoTable_cells_selected)})
  observe({
    #Catch some irrelavant conditions
    if ( !AnyCellSelected() ) return()
    DemoTableSelectedCell <- input$DemoTable_cells_selected
    if ( nrow(DemoTableSelectedCell) == 0 ) return()
    #Extract selected cell indices
    RowSelected <- DemoTableSelectedCell[1,1]
    ColSelected <- DemoTableSelectedCell[1,2]
    #Unselect the selected cell to avoid repeated call of this
    #observe() function - does not work
    DTproxy <- DT::dataTableProxy(outputId="DemoTable")
    DT::selectCells(DTproxy, NULL)
    #Report to console whether this function is called for
    #debugging purpose - gets called over and over again.
    print("called")
    #Change the value in the selected cell on selection
    UpdateValue(row=RowSelected,col=ColSelected)
  })
}

# Run the application 
shinyApp(ui = ui, server = server)

[Peter2]

Ok, I solved it: The solution is to avoid using a "classical" function call to UpdateValue(parameters) and use a reactive value and an observer instead. I.e. to (1) have a reactive variable "UpdateCellTrigger" which is a dataframe containing the function parameters (i.e. the indices of the selected cell) and (2) implement the UpdateValue() function as an observer of this reactive variable (see below for code). It seems that mixing reactive programming and standard R function calls can lead problems - maybe related to the timing of the execution of differents parts of the code. It seems sticking as close as possible to the reactive programming approach avoids some of these issues.
Cheers!

library(shiny)
library(DT)

ui <- fluidPage(
  #A minimal GUI
  mainPanel(
    DT::dataTableOutput("DemoTable")
  )
)


server <- function(input, output) {

  #A reactive data frame with some initialization  
  DemoTable <- data.frame(
    value1 = runif(0,1,n=4),
    value2 = runif(0,1,n=4)
  )
  makeReactiveBinding("DemoTable")
  

  
  #Link the demo table reactive to the output datatable
  output$DemoTable = DT::renderDataTable({
    MyDT <- datatable(data=DemoTable,selection=list(mode="single",target="cell"))
    return(MyDT)
  })


  #Does not work:
  #A function to change the value in the selected cell
  # UpdateValue <- function(row,col) {
  #   tmp <- DemoTable
  #   tmp[row,col] <- runif(0,1,n=1)
  #   DemoTable <<- tmp
  # }
  
  #Does work:
  
  #1. Define a reactive that acts as a trigger for the function
  #call and transfers the function arguments
  UpdateCellTrigger <- data.frame(
    RowIndex = -1,
    ColIndex = -1
  )
  makeReactiveBinding("UpdateCellTrigger")
  
  #2. Define the update function as an observer
  #of the trigger
  observe({
    #Ignore if trigger is not set
    if ( UpdateCellTrigger$RowIndex == -1 ) return()
    #Extract selected cell indices
    RowIndex <- UpdateCellTrigger$RowIndex
    ColIndex <- UpdateCellTrigger$ColIndex
    #Reset trigger
    UpdateCellTrigger$RowIndex <<- -1
    UpdateCellTrigger$ColIndex <<- -1
    #Update values of table
    DemoTable[RowIndex,ColIndex] <<- runif(0,1,n=1)
  })
  
  
  #Observe cell select event of table
  AnyCellSelected <- reactive({!is.null(input$DemoTable_cells_selected)})
  observe({
    #Catch some irrelavant conditions
    if ( !AnyCellSelected() ) return()
    DemoTableSelectedCell <- input$DemoTable_cells_selected
    if ( nrow(DemoTableSelectedCell) == 0 ) return()
    #Extract selected cell indices
    RowSelected <- DemoTableSelectedCell[1,1]
    ColSelected <- DemoTableSelectedCell[1,2]
    #Unselect the selected cell to avoid repeated call of this
    #observe() function - does not work
    DTproxy <- DT::dataTableProxy(outputId="DemoTable")
    DT::selectCells(DTproxy, NULL)
    #Report to console whether this function is called for
    #debugging purpose
    print("called")
    #Change the value in the selected cell on selection
    UpdateCellTrigger <<- data.frame(
      RowIndex = RowSelected,
      ColIndex = ColSelected
    )
  })
}

# Run the application 
shinyApp(ui = ui, server = server)

[Peter2]

For the record: Actually, that was only part of the solution. The problem re-occurred when transfering it from the minimal working example to the actual application. The problem was that the actual update operation of the cell value involves a (slow) operation on an external database, which brought me back to the infinite loop.

I ended up with a workaround: I implemented a blacklist for cells (by cell index) which have recently been updated. Blacklisted cells will not get updated as long as they are on the list. The blacklist is cleared every 2s by a reactiveTimer(). A little ugly, but works stable.