Embedded selectInput in DT R Shiny with Large Table

Question

I found an extremely helpful answer here that is almost what I need.

This solution of embedding a selectInput in a DataTable works great, but not for those with many rows.

The issue is that the function shinyInput() uses a for loop that can't keep up with tables with rows greater than 1000. It makes the table run far too slowly.

Generating this many input objects takes time. I will need to trigger an SQL UPDATE statement after, but that is another issue.

Is there a way to make this run faster, maybe by generating input objects on the fly as the user clicks through pages?

Another issue is that when the table finally does load with all the embedded objects, if you try to change one of the selectInput's, you will notice that the table takes a long time to catch up.

See this example app:

library(shiny)
library(DT) 

DF = matrix(round(rnorm(1000000, mean = 0, sd = 1), 2), ncol = 50)

runApp(list(
  ui = basicPage(
    h2('A large dataset'),
    DT::dataTableOutput('mytable'),
    h2("Selected"),
    tableOutput("checked")
  ),

  server = function(input, output) {

    # Helper function for making checkbox
    shinyInput = function(FUN, len, id, ...) { 
      inputs = character(len) 
      for (i in seq_len(len)) { 
        inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...))
        print(i)
      } 
      inputs 
    } 

    # Helper function for reading checkbox
    shinyValue = function(id, len) { 
      unlist(lapply(seq_len(len), function(i) { 
        value = input[[paste0(id, i)]] 
        if (is.null(value)) NA else value 
      })) 
    }

    # Create select input objects to embed in table
    Rating = shinyInput(selectInput,
                        nrow(DF),
                        "selecter_",
                        choices=1:5,
                        width="60px")

    # Data frame to display
    DF_display = data.frame(DF, Rating)

    # Datatable with selectInput
    output$mytable = DT::renderDataTable(
      DF_display,
      selection = 'none',
      server = FALSE,
      escape = FALSE,
      options = list( 
        paging = TRUE,
        pageLength = 20,
        lengthMenu = c(5, 10, 20, 100, 1000, 10000),
        preDrawCallback = JS('function() { 
                             Shiny.unbindAll(this.api().table().node()); }'), 
        drawCallback = JS('function() { 
                          Shiny.bindAll(this.api().table().node()); } '))
    )

    # Read select inputs
    output$checked <- renderTable({
      data.frame(selected = shinyValue("selecter_", nrow(DF)))
    })
    }
))

Answer 1

I have once implemented checkboxGroupButtons for an entire column of a data.frame. The following snippet adds such a column to the dataframe df, whereby options are "Aktiv" and "Final":

• "Aktiv" is selected if a[i] == 0
• "Final" is selected if a[i] == 1

Analogously, try out other shiny elements like selectInput().

df <- data.frame(a = c(rep(0,5), rep(1,5))
choices <- c("Aktiv", "Final")
wanted_column <- character(nrow(df))

# add shiny element to the dataframe
for (i in seq_len(nrow(df))) {        
    for (j in seq_len(length(choices))) {
      if (df$a[i] == 0) {
        selected <- choices[0]
      } else {
        selected <- choices[1]
      }
    }
    wanted_column[i] <- as.character(checkboxGroupButtons(
      inputId = paste0("df_checkbox_row_", i),
      label = NULL,
      choices = choices,
      selected = selected,
      justified = TRUE,
      individual = TRUE,
      status = "primary"
    ))
}  
df <- data.frame(df, wanted_column)

#callback for reaction to user-side selections 
callbackId <- "dt_checkbox_event"
column <- 2
callback <- c(
  paste0("table.on('change.dt', 'td:nth-child(", column, ")', function() {"),
  "var row_ = table.cell(this).index().row + 1;",
  "var col = table.cell(this).index().column;",
  "var checkboxesName = 'df_checkbox_row_' + row_",
  "var checkboxes = document.getElementsByName(checkboxesName)",
  "var checkedStatuses = []",
  "checkboxes.forEach(myfunc)",
  "function myfunc(item) {",
  "    if (item.checked) {",
  "       checkedStatuses.push(item.value);",
  "    }",
  "}",
  "var data = [row_, col, checkedStatuses];",
  paste0("Shiny.onInputChange('", callbackId, "',data);"),
  "});"
)


dt <- data.table(df,
                 escape = FALSE, #to enable HTML within the datatable
                 selection = "none",
                 callback = JS(callback))

Even if the question was posted years ago, it maybe still helps someone.