Maintain table order and page selection in Shiny JS call to edit cell

The code below replicates the problem. I have an app for users to update values and I need to refresh the page after they update the values because the colors need to update, but I haven't been able to make it so pagination and ordering are preserved after the edits. GPT helped write a minimal working example but it couldn't solve the issue.

library(shiny)
library(DT)

ui <- fluidPage(
  tags$head(
    tags$script(HTML("
      // Custom handler: update the select element and row color without redrawing.
      Shiny.addCustomMessageHandler('updateDropdown', function(message) {
        var tableEl = $('#demo_table table');
        if (!tableEl.length) {
          console.warn('Table element not found');
          return;
        }
        var table = tableEl.DataTable();
        var colIndex = 2; // Category column index.
        var rowIndexes = table.rows().indexes().filter(function(idx) {
          return table.row(idx).data()[0] == message.row;
        });
        if (rowIndexes.length > 0) {
          var rowIndex = rowIndexes[0];
          var cellNode = table.cell(rowIndex, colIndex).node();
          $(cellNode).find('select').val(message.new_value);
          $(table.row(rowIndex).node()).css('background-color', message.new_color);
        }
      });
    "))
  ),
  DTOutput("demo_table")
)

server <- function(input, output, session) {
  # Create reactive data.
  data <- reactiveVal(data.frame(
    ID = 1:100,
    Value = sample(1:1000, 100),
    Category = sample(c("A", "B", "C"), 100, replace = TRUE),
    stringsAsFactors = FALSE
  ))
  
  # Helper function to create dropdown HTML.
  createDropdown <- function(row_id, current) {
    sprintf(
      '<select data-row="%s" onchange="Shiny.setInputValue(\'category_change\', {row: %s, value: this.value, nonce: Math.random()})">
         <option value=\"A\" %s>A</option>
         <option value=\"B\" %s>B</option>
         <option value=\"C\" %s>C</option>
       </select>',
      row_id, row_id,
      ifelse(current == "A", "selected", ""),
      ifelse(current == "B", "selected", ""),
      ifelse(current == "C", "selected", "")
    )
  }
  
  # Render the table only once by isolating the reactive data.
  output$demo_table <- renderDT({
    df <- isolate(data())
    # Replace Category column with dropdown HTML.
    df$Category <- sapply(df$ID, function(id) {
      cat <- data()[data()$ID == id, "Category"]
      createDropdown(id, cat)
    })
    datatable(
      df,
      escape = FALSE,
      rownames = FALSE,
      options = list(
        pageLength = 10,
        stateSave = TRUE,
        order = list(list(1, "asc")),
        rowCallback = JS("function(row, data, index) {
          // Set hidden row id.
          $(row).attr('data-row-id', data[0]);
          // Color rows based on Value.
          var val = parseInt(data[1]);
          $(row).css('background-color', val > 500 ? 'lightblue' : 'white');
        }")
      )
    )
  }, server = TRUE)
  
  proxy <- dataTableProxy("demo_table")
  
  # When the dropdown value changes, update the data and replace the table data.
  observeEvent(input$category_change, {
    req(input$category_change)
    info <- input$category_change
    df <- data()
    row_idx <- which(df$ID == info$row)
    if (length(row_idx) == 0) return()
    
    # Update the underlying data.
    df$Category[row_idx] <- info$value
    data(df)
    
    # Rebuild the table data with the updated dropdown HTML.
    new_df <- isolate(data())
    new_df$Category <- sapply(new_df$ID, function(id) {
      cur <- df[df$ID == id, "Category"]
      createDropdown(id, cur)
    })
    
    # Update the table without resetting pagination.
    replaceData(proxy, new_df, resetPaging = FALSE)
  })
}

shinyApp(ui, server)

I tried tweaking the JS by directly updating the DOM but that didn't work. It works if it's a single page. I have looked at other posts - the problem in here is similar, but they don't use JS as the option is not a dropdown, so I wasn't able to replicate the solution.

Solution

Thanks to this I was able to figure out, that the current page can be retrieved from the table object. Also there are different events observing the table:

init.dt -> when the table reloads
order.dt -> when the user sorts by any column
length.dt -> when the user changes the page length
page.dt -> when the user changes the current page

So we can save the lastPage / ordering Column and Ordering Direction in global variables and update them whenever the user fires any of above mentioned events. Using this, we can restore these on every init. So everytime the user changes a dropdow, the table is reloaded and init.dt fires; we can now restore the saved column to order by, the direction and the last page. You can probably do the same for the last pageLength, but I let this at 10 (meaning the nr of page elements will allways reset to 10 after the edit).

Code

library(shiny)
library(DT)

ui <- fluidPage(
  tags$head(
    tags$script("
      // Store page info and order info accross all HTML
      var lastPage = 1;
      var orderByCol = 1;
      var orderDir = 'asc';
      
    ")
  ),
  DTOutput("demo_table")
)

server <- function(input, output, session) {
  # Create reactive data.
  data <- reactiveVal(data.frame(
    ID = 1:100,
    Value = sample(1:1000, 100),
    Category = sample(c("A", "B", "C"), 100, replace = TRUE),
    stringsAsFactors = FALSE
  ))
  
  # Helper function to create dropdown HTML.
  createDropdown <- function(row_id, current) {
    sprintf(
      '<select data-row="%s" onchange="Shiny.setInputValue(\'category_change\', {row: %s, value: this.value})">
         <option value=\"A\" %s>A</option>
         <option value=\"B\" %s>B</option>
         <option value=\"C\" %s>C</option>
       </select>',
      row_id, row_id,
      ifelse(current == "A", "selected", ""),
      ifelse(current == "B", "selected", ""),
      ifelse(current == "C", "selected", "")
    )
  }
  
  # Render the table only once by isolating the reactive data.
  output$demo_table <- renderDT({
    df <- isolate(data())
    # Replace Category column with dropdown HTML.
    df$Category <- sapply(df$ID, function(id) {
      cat <- data()[data()$ID == id, "Category"]
      createDropdown(id, cat)
    })
    datatable(
      df,
      escape = FALSE,
      callback = JS("
        
        table.on('init.dt', function(){
          var pageInfo = table.page.info();
          console.log('init...');
          console.log('Last Page: ' + lastPage);
          console.log('Order by col: ' + orderByCol);
          table.page(lastPage-1).draw(false);
          table.order([orderByCol, orderDir]).draw(false); // Restore sorting
          
        });
        
        table.on('order.dt', function(e, settings) {
          var orderInfo = table.order();
          console.log('ordering...' + orderInfo);
          if (orderInfo.length > 0){
            console.log('there is info.');
            orderByCol = orderInfo[0][0];
            orderDir = orderInfo[0][1];
          }
            
        });
    
        table.on('page.dt', function(){
          var pageInfo = table.page.info();
          Shiny.setInputValue('pageNumber', pageInfo.page + 1);
          lastPage = pageInfo.page + 1;
        });
    
        table.on('length.dt', function(){
          var pageInfo = table.page.info();
          Shiny.setInputValue('pageNumber', pageInfo.page + 1);
        });
      "),
      rownames = FALSE,
      selection = 'none',
      options = list(
        pageLength = 10,
        rowCallback = JS("function(row, data, index) {
          // Set hidden row id.
          $(row).attr('data-row-id', data[0]);
          // Color rows based on Value.
          var val = parseInt(data[1]);
          $(row).css('background-color', val > 500 ? 'lightblue' : 'white');
        }")
      )
    )
  })
  
  # When the dropdown value changes, update the data and replace the table data.
  observeEvent(input$category_change, {
    req(input$category_change)
    info <- input$category_change
    df <- data()
    row_idx <- which(df$ID == as.numeric(info$row))
    df$Category[row_idx] <- info$value
    data(df)
  })
}

shinyApp(ui, server)