Possible bug - DT caption strange behavior when selectInput is generated in every row

[pakom]

I noticed something strange when creating selectInputs in every row of a DT and fetching the user input from it. Consider the code below (apologies for not being minimal). It captures the user input and prints it in the console. When the user adds variables in the table on the right, makes changes to the selectInput fields, the selections are printed on the screen. However, if the user removes the variables on the right and enters new ones, the new selections made using the selectInput fields are no longer updated. Strangely, if I remove the caption (caption = "Selected variables") from the selectedVars DT everything works just fine.

This sounds odd, I don't understand how the caption can be related. Is this a bug?

library(shiny)
library(DT)
library(data.table)


names.and.labels <- data.table(Variables = c("ASBG01", "ASBG03", "ASBG04", "ASBG05A", "ASBG05B", "ASBG05C", "ASBG05D", "ASBG05E", "ASBG05F", "ASBG06"), Variable_Labels = c("GEN/SEX OF STUDENT", "GEN/OFTEN SPEAK <LANG OF TEST> AT HOME", "GEN/AMOUNT OF BOOKS IN YOUR HOME", "GEN/HOME POSSESS/COMPUTER OR TABLET", "GEN/HOME POSSESS/STUDY DESK", "GEN/HOME POSSESS/OWN ROOM", "GEN/HOME POSSESS/INTERNET CONNECTION", "GEN/HOME POSSESS/<COUNTRY SPECIFIC>", "GEN/HOME POSSESS/<COUNTRY SPECIFIC>", "GEN/ABOUT HOW OFTEN ABSENT FROM SCHOOL"))

names.and.levels <- list(ASBG01 = c("Girl", "Boy", "Omitted or invalid"),
                         ASBG03 = c("I always speak <language of test> at home", "I almost always speak <language of test> at home", "I sometimes speak <language of test> and sometimes speak another language at home", "I never speak <language of test> at home", "Omitted or invalid"),
                         ASBG04 = c("None or very few (0-10 books)", "Enough to fill one shelf (11-25 books)", "Enough to fill one bookcase (26-100 books)", "Enough to fill two bookcases (101-200 books)", "Enough to fill three or more bookcases (more than 200)", "Omitted or invalid"),                                    
                         ASBG05A = c("Yes", "No", "Omitted or invalid"),
                         ASBG05B = c("Yes", "No", "Omitted or invalid"),
                         ASBG05C = c("Yes", "No", "Omitted or invalid"),
                         ASBG05D = c("Yes", "No", "Omitted or invalid"),
                         ASBG05E = c("Yes", "No", "Omitted or invalid"),
                         ASBG05F = c("Yes", "No", "Omitted or invalid"),
                         ASBG06 = c("Once a week", "Once every two weeks", "Once a month", "Never or almost never", "Omitted or invalid"))


ui <- fluidPage(
  
  tags$head(tags$script(
    HTML(
      "Shiny.addCustomMessageHandler('unbindDT', function(id) {
               var $table = $('#'+id).find('table');
                if($table.length > 0) {
                 Shiny.unbindAll($table.DataTable().table().node());
                }
               })")
  )),
  
  fluidRow(
    column(width = 5, DTOutput(outputId = "allAvailVars")),
    column(width = 1, uiOutput(outputId = "arrowRight"), uiOutput(outputId = "arrowLeft")),
    column(width = 6,DTOutput(outputId = "selectedVars")
    )
  )
)

server <- function(input, output, session) {
  
  observe({
    
    initial.selected.vars <- data.table(Variables = as.character(), Variable_Labels = as.character())
    
    allVars <- reactiveValues(availVars = names.and.labels, selectedVars = initial.selected.vars)
    
    output$arrowRight <- renderUI({
      actionButton(inputId = "arrowRight", label = NULL, icon("angle-right"), width = "50px")
    })
    
    output$arrowLeft <- renderUI({
      actionButton(inputId = "arrowLeft", label = NULL, icon("angle-left"), width = "50px")
    })
    
    observeEvent(input$arrowRight, {
      req(input$allAvailVars_rows_selected)
      allVars$selectedVars <- rbind(isolate(allVars$selectedVars), allVars$availVars[input$allAvailVars_rows_selected, , drop = FALSE])
      allVars$selectedVars <- allVars$selectedVars[complete.cases(allVars$selectedVars[ , "Variables"]), , drop = FALSE]
      allVars$availVars <- isolate(allVars$availVars[-input$allAvailVars_rows_selected, , drop = FALSE])
      
      session$sendCustomMessage("unbindDT", "selectedVars")
    })
    
    observeEvent(input$arrowLeft, {
      req(input$selectedVars_rows_selected)
      allVars$availVars <- rbind(isolate(allVars$availVars), allVars$selectedVars[input$selectedVars_rows_selected, , drop = FALSE])
      allVars$availVars <- allVars$availVars[complete.cases(allVars$availVars[ , "Variables"]), , drop = FALSE]
      allVars$selectedVars <- isolate(allVars$selectedVars[-input$selectedVars_rows_selected, , drop = FALSE])
      
      session$sendCustomMessage("unbindDT", "selectedVars")
    })
    
    # Create input and value functions to generate the "selectInput" on each row and collect their values. Note that two different input functions are created because the type of contrasts and reference categories have different structure.
    shinyInput1 <- function(FUN, len, id, ...) {
      inputs <- character(len)
      lapply(seq_len(len), function(i) {
        inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...))
      })
    }
    
    shinyInput2 <- function(FUN, id, ...) {
      inputs <- as.character(FUN(id, label = NULL, ...))
      inputs
    }
    
    shinyValue <- function(id, len) {
      unlist(lapply(seq_len(len), function(i) {
        value = input[[paste0(id, i)]]
        if (is.null(value)) NA else value
      }))
    }
    
    # Create empty user-entered reactive values for all available reference categories.
    old.contrasts <- reactiveValues(values = NULL)
    new.contrasts <- reactiveValues(contr = NULL, values = NULL)
    
    # Observe the changes in user selection and update the reactive values from above.
    observe({
      if(nrow(allVars$selectedVars) > 0) {
        old.contrasts$values <- cbind(
          V1 = data.table(allVars$selectedVars[ , Variables]),
          V2 = data.table(allVars$selectedVars[ , Variable_Labels]),
          V3 = data.table(sapply(X = names.and.levels, length)[allVars$selectedVars[ , Variables]]),
          V4 = shinyInput1(FUN = selectInput, id = 'dropcontrast', len = nrow(allVars$selectedVars), choices = c("Dummy", "Deviation", "Simple"), width = "100%"),
          V5 = lapply(seq_along(1:nrow(allVars$selectedVars)), function(i) {
            shinyInput2(FUN = selectInput, id = paste0("droprefcat", i), choices = names.and.levels[allVars$selectedVars[ , Variables]][i])
          })
        )
        
        if(nrow(old.contrasts$values) > 0) {
          new.contrasts$contr <- shinyValue(id = "dropcontrast", len = nrow(old.contrasts$values))
          new.contrasts$values <- shinyValue(id = "droprefcat", len = nrow(old.contrasts$values))
          
          print(new.contrasts$contr)
          print(new.contrasts$values)
        }
      }
    })
    
    # Render the data table with available variables.
    output$allAvailVars <- renderDT({
      allVars$availVars
    },
    rownames = FALSE, colnames = c("Names", "Labels"),
    options = list(
      dom = "ti",
      autoWidth = TRUE))
    
    
    # Render the data table with selected variables.
    output$selectedVars <- renderDT({
      if(nrow(allVars$selectedVars) == 0) {
        data.table(Variables = as.character(), Variable_Labels = as.character(), n.cat = as.character(), contrast = as.character(), ref.cat = as.numeric())
      } else {
        old.contrasts$values
      }
    },
    caption = "Selected variables",
    rownames = FALSE,
    escape = FALSE,
    extensions = list("Scroller"),
    colnames = c("Names", "Labels", "N cat.", "Contrast", "Ref. cat."),
    options = list(
      # preDrawCallback = JS('function() {
      # Shiny.unbindAll(this.api().table().node()); }'),
      drawCallback = JS('function() {
                        Shiny.bindAll(this.api().table().node()); } '),
      
      dom = "ti",
      autoWidth = TRUE,
      deferRender = TRUE, scrollY = 100, scroller = TRUE))
  })
}

shinyApp(ui, server)