r shiny DT cell drop down menus' values are not updated and not collected anymore

Question

I have a large shiny app with a lot of DTs. One of these DTs is dynamic and takes input from another DT through user interaction. When a row is added, two drop down lists are created inside. These drop down lists take values based on variable properties and provide text output (see the example below). When changing the selected categories of the drop down lists, the text output was also changing. Everything was working just fine. However, last week I noticed that the outputs are of NAs only and when selecting values from the drop down lists nothing changes, the reactive values are also not updated (tried to print them directly from the code into the Rstudio console).

The computer I use for development runs Linux with R 4.3.2, shiny 1.8.0 and DT 0.31. I tried to reproduce the issue on a different machine that I use for testing. It wuns Windows 10 and is also with R 4.3.2, but shiny is 1.7.5.1 and DT is 0.30. On the testing machine the example from below worked flawlessly. According to the shiny changelog, version 1.8.0 comes with a breaking change. I personally can't tell if this is the reason why my app does not work as intended anymore or not. The explanation on how to avoid the asynchronous execution the changelog provides is not something I personally can comprehend.

EDIT: I've tested it on yet another machine under Windows 10 with shiny 1.8.0 and DT 0.31, it fails there as well.

There are somewhat similar examples on SO that I checked and by the time of posting they were even marked as accepted solutions, but when trying to run them now they don't behave as intended anymore. Such are, for example this one and this one. In addition, similar problems were noted in the issues on shiny's GitHub page, like #3965 and possibly #3979.

Here is the data that I use:

mydt <- structure(data.table(
      BCBG03A = structure(c(NA, 1L, 2L, 1L, 2L, 1L, 3L, 2L, 1L, 1L, 3L, 2L, 1L, 1L, 4L), levels = c("0 to 10%", "11 to 25%", "26 to 50%", "More than 50%"), class = "factor", variable.label = "GEN/STUDENTS BACKGROUND/ECONOMIC DISADVA"), 
      BCBG05A = structure(c(3L, 2L, 2L, 2L, 2L, 2L, 4L, 6L, 2L, 1L, 6L, 2L, 6L, 1L, 7L), levels = c("More than 500,000 people", "100,001 to 500,000 people", "50,001 to 100,000 people", "30,001 to 50,000 people", "15,001 to 30,000 people", "3,001 to 15,000 people", "3,000 people or fewer"), class = "factor", variable.label = "GEN/HOW MANY PEOPLE LIVE IN AREA"), 
      BCBG06C = structure(c(3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, NA, 3L, 3L, 3L, 3L), levels = c("6 days", "5 1/2 days", "5 days", "4 1/2 days", "4 days", "Other"), class = "factor", variable.label = "GEN/INSTRUCTIONAL DAYS IN 1 CALENDER WEEK"), 
      BCBG08B = structure(c(1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 2L, 1L, NA, 2L, 1L, 1L, 2L), levels = c("Yes", "No"), class = "factor", variable.label = "GEN/ASSISTANCE AVAILABLE"),
      BCBG13AC = structure(c(2L, 1L, 4L, 2L, 1L, 1L, 1L, 2L, 1L, 1L, NA, 3L, 1L, 1L, 1L), levels = c("Not at all", "A little", "Some", "A lot"), class = "factor", variable.label = "GEN/SHORTAGE/GEN/SCHOOL BUILDINGS"), 
      BCBG14J = structure(c(2L, 2L, 2L, 1L, 3L, 2L, 3L, 2L, 2L, 1L, NA, 2L, 2L, 1L, 3L), levels = c("Very high", "High", "Medium", "Low", "Very low"), class = "factor", variable.label = "GEN/SCH CHARACTER/ABILITY TO REACH GOALS"), 
      BCBG15B = structure(c(1L, 1L, 1L, 2L, 2L, 1L, 1L, 1L, 1L, 2L, NA, 2L, 2L, 1L, 2L), levels = c("Agree a lot", "Agree a little", "Disagree a little", "Disagree a lot"), class = "factor", variable.label = "GEN/AGREEMENT/PROMOTE INTEREST")), class = c("data.table", "data.frame"))

And here is the (not so) minimal reproducible example:

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

shinyApp(
  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 = "linRegAllAvailableVars")),
             column(width = 2, uiOutput(outputId = "linRegArrowSelIndepCatBckgVarsRight"),
                    uiOutput(outputId = "linRegArrowSelIndepCatBckgVarsLeft")),
             column(width = 5, DTOutput(outputId = "linRegIndepCatBckgVars"))), br(), br(),
    fluidRow(verbatimTextOutput(outputId = "outputContrasts"))
    
  ),
  
  server <- function(input, output, session) {
    file.lin.reg <- reactiveValues(var.levels = NULL, var.unique.values = NULL, lin.reg.syntax = NULL)
    file.lin.reg$loaded <- mydt
    
    observe({
      lin.reg.initial.available.vars <- mydt
      lin.reg.initial.available.vars <- data.table(Variables = colnames(mydt), Variable_Labels = sapply(mydt, attr, "variable.label"), order_col = 1:length(colnames(mydt)))
      lin.reg.initial.selected.indep.cat.bckg.vars <- data.table(Variables = as.character(), Variable_Labels = as.character(), order_col = as.numeric())
      linRegAllVars <- reactiveValues(linRegAvailVars = lin.reg.initial.available.vars, linRegSelectedIndepCatBckgVars = lin.reg.initial.selected.indep.cat.bckg.vars)
      file.lin.reg$var.levels <- lapply(X = file.lin.reg$loaded, FUN = function(i) {
        attr(x = i, which = "levels")
      })
      
      file.lin.reg$var.unique.values <- file.lin.reg$var.levels
      
      # Make the action buttons to move the variables between the two tables and set actions on click.
      output$linRegArrowSelIndepCatBckgVarsRight <- renderUI({
        actionButton(inputId = "linRegArrowSelIndepCatBckgVarsRight", label = NULL, icon("angle-right"), width = "50px")
      })
      
      output$linRegArrowSelIndepCatBckgVarsLeft <- renderUI({
        actionButton(inputId = "linRegArrowSelIndepCatBckgVarsLeft", label = NULL, icon("angle-left"), width = "50px")
      })
      
      observeEvent(input$linRegArrowSelIndepCatBckgVarsRight, {
        req(input$linRegAllAvailableVars_rows_selected)
        linRegAllVars$linRegSelectedIndepCatBckgVars <- rbind(isolate(linRegAllVars$linRegSelectedIndepCatBckgVars), linRegAllVars$linRegAvailVars[input$linRegAllAvailableVars_rows_selected, , drop = FALSE])
        linRegAllVars$linRegSelectedIndepCatBckgVars <- linRegAllVars$linRegSelectedIndepCatBckgVars[complete.cases(linRegAllVars$linRegSelectedIndepCatBckgVars[ , "Variables"]), , drop = FALSE]
        linRegAllVars$linRegAvailVars <- isolate(linRegAllVars$linRegAvailVars[-input$linRegAllAvailableVars_rows_selected, , drop = FALSE])
        session$sendCustomMessage("unbindDT", "linRegIndepCatBckgVars")
      })
      
      observeEvent(input$linRegArrowSelIndepCatBckgVarsLeft, {
        req(input$linRegIndepCatBckgVars_rows_selected)
        linRegAllVars$linRegAvailVars <- rbind(isolate(linRegAllVars$linRegAvailVars),        linRegAllVars$linRegSelectedIndepCatBckgVars[input$linRegIndepCatBckgVars_rows_selected, , drop = FALSE])
        linRegAllVars$linRegAvailVars <- linRegAllVars$linRegAvailVars[complete.cases(linRegAllVars$linRegAvailVars[ , "Variables"]), , drop = FALSE]
        linRegAllVars$linRegSelectedIndepCatBckgVars <- isolate(linRegAllVars$linRegSelectedIndepCatBckgVars[-input$linRegIndepCatBckgVars_rows_selected, , drop = FALSE])
        session$sendCustomMessage("unbindDT", "linRegIndepCatBckgVars")
      })
      
      # Output the tble with the available variables.
      output$linRegAllAvailableVars <- renderDT({
        setkeyv(x = linRegAllVars$linRegAvailVars, cols = "order_col")
      },
      rownames = FALSE,
      filter = "top",
      colnames = c("Names", "Labels", "sortingcol"),
      extensions = list("Scroller"),
      options = list(
        language = list(zeroRecords = "No variables available"),
        initComplete = JS("function(settings, json) {", "$(this.api().table().header()).css({'background-color': '#000000', 'color': '#ffffff'});", "}"),
        dom = "ti",
        searchHighlight = FALSE,
        ordering = FALSE,
        autoWidth = TRUE,
        columnDefs = list(list(width = '75px', targets = 0), list(visible = FALSE, targets = 2)),
        deferRender = TRUE, scrollY = 200, scroller = TRUE
      ))
      
      # Output the table with the contrasts and reference categories.
      output$linRegIndepCatBckgVars <- renderDT({
        if(nrow(linRegAllVars$linRegSelectedIndepCatBckgVars) == 0) {
          data.table(Variables = as.character(), Variable_Labels = as.character(), n.cat = as.character(), contrast = as.character(), ref.cat = as.numeric(), order_col = as.character())
        } else {
          lin.reg.contrasts$values
        }
      },
      rownames = FALSE,
      selection = "single",
      colnames = c("Names", "Labels", "N cat.", "Contrast", "Ref. cat.", "sortingcol"),
      extensions = list("Scroller"),
      escape = FALSE,
      options = list(
        language = list(zeroRecords = "No variables have been selected"),
        initComplete = JS("function(settings, json) {", "$(this.api().table().header()).css({'background-color': '#000000', 'color': '#ffffff'});", "}"),
        dom = "ti",
        searchHighlight = FALSE,
        ordering = FALSE,
        autoWidth = TRUE,
        columnDefs = list(list(width = '75px', targets = 0), list(width = '40px', targets = 2:4), list(className = 'dt-center', targets = 2:4), list(visible = FALSE, targets = 5)),
        preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
        drawCallback = JS('function() {Shiny.bindAll(this.api().table().node());} '),
        deferRender = TRUE, scrollY = 200, scroller = TRUE
      ))
      
      
      # Define functions for generating the inputs and fetch the changes.
      generate.lin.reg.contr.new.inputs <- function(FUN, len, id, ...) {
        inputs <- character(len)
        lapply(seq_len(len), function(i) {
          inputs[i] <- as.character(FUN(paste0(id, i), label = NULL, ...))
        })
      }
      
      generate.lin.reg.refcat.new.inputs <- function(FUN, id, ...) {
        as.character(FUN(id, label = NULL, ...))
      }
      
      gather.lin.reg.cat.new.inputs.data <- 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, these will be updated and used further to generate, display and update the table with the available reference values chosen by the user in the "selectInput" fields.
      lin.reg.contrasts <- reactiveValues(values = NULL)
      new.lin.reg.contrasts <- reactiveValues(contrasts = NULL, ref.cats = NULL)
      
      # Observe the changes in user selection and update the reactive values from above. Note that if the user adds PVs as categorical variables, the contrast coding schemes and reference categories are made unavailable. Adding PVs will be flagged later with warning message under all tables.
      observe({
        if(nrow(linRegAllVars$linRegSelectedIndepCatBckgVars) > 0) {
          lin.reg.contrasts$values <- cbind(
            V1 = data.table(linRegAllVars$linRegSelectedIndepCatBckgVars[ , Variables]),
            V2 = data.table(linRegAllVars$linRegSelectedIndepCatBckgVars[ , Variable_Labels]),
            V3 = data.table(sapply(X = file.lin.reg$var.unique.values, FUN = function(i) {
              length(i)
            })[linRegAllVars$linRegSelectedIndepCatBckgVars[ , Variables]]),
            V4 = generate.lin.reg.contr.new.inputs(FUN = selectInput, id = 'linregcontrast', len = nrow(linRegAllVars$linRegSelectedIndepCatBckgVars), choices = c("Dummy", "Deviation", "Simple"), width = "100%"),
            V5 = lapply(seq_along(1:nrow(linRegAllVars$linRegSelectedIndepCatBckgVars)), function(i) {
              generate.lin.reg.refcat.new.inputs(FUN = selectInput, id = paste0("linregrefcat", i), choices = file.lin.reg$var.unique.values[linRegAllVars$linRegSelectedIndepCatBckgVars[ , Variables]][i], width = "100%")
            }),
            V6 = data.table(linRegAllVars$linRegSelectedIndepCatBckgVars[ , order_col])
          )
          
          # Get the passed reference values.
          if(nrow(lin.reg.contrasts$values)) {
            new.lin.reg.contrasts$contrasts <- gather.lin.reg.cat.new.inputs.data(id = "linregcontrast", len = nrow(lin.reg.contrasts$values))
            new.lin.reg.contrasts$ref.cats <- gather.lin.reg.cat.new.inputs.data(id = "linregrefcat", len = nrow(lin.reg.contrasts$values))
          }
        }
      })
      
      # Render the output
      output$outputContrasts <- renderText({paste(new.lin.reg.contrasts$contrasts, new.lin.reg.contrasts$ref.cats)})
    })
  }
)

Sister

Answer 1

You have to get the HTML dependencies of the select(ize)Input:

select_input <- selectInput("x", label = NULL, choices = c("A", "B"))
deps <- htmltools::findDependencies(select_input)

Then anywhere in your UI you have to include these dependencies as follows:

tagList(deps)

Now you have to initialize the selectInput included in your table:

    initComplete = JS(c(
      "function(settings, json) {",
      "  $('#linregcontrast').selectize();",
      "  $('#linregrefcat1').selectize();",
      "  $('#linregrefcat2').selectize();",
      ......
      "}"
    ))

Maybe you can do like this instead (I didn't try):

    initComplete = JS(c(
      "function(settings, json) {",
      "  $('#linregcontrast').selectize();",
      "  $('[id^=linregrefcat]').selectize();",
      "}"
    ))

Now that should work.

Tactile

Thank you. I am getting an error Error in eval(exprs, envir) : object 'deps' not found. Further, I guess choices = c("A", "B")) shall be replaced with mine (Dummy, Deviation, and Simple), as I don't have these? I don't have such in the table as per the choices generated (contrasts and refcats). – Sister

@Sister deps is defined at the beginning of my answer. The choices here have no importance: we use this select input only to get the HTML dependencies (here there's only one HTML dependency: the JavaScript library selectize). – Lamm

OK, now I understand what you mean. – Sister

Answer 2

OK, so the last comment from Stéphane Laurent made me thinking about the JavaScript library selectize and I did a bit more digging. The solution is to add selectize = FALSE when calling the functions to generate inputs (generate.lin.reg.contr.new.inputs and generate.lin.reg.refcat.new.inputs).

So the following two pieces of code

generate.lin.reg.contr.new.inputs(FUN = selectInput, id = 'linregcontrast',
len = nrow(linRegAllVars$linRegSelectedIndepCatBckgVars), choices = c("Dummy", "Deviation", "Simple"),
width = "100%")

generate.lin.reg.refcat.new.inputs(FUN = selectInput, id = paste0("linregrefcat", i),
choices = file.lin.reg$var.unique.values[linRegAllVars$linRegSelectedIndepCatBckgVars[ , Variables]][i],
width = "100%")

need to be changed to

generate.lin.reg.contr.new.inputs(FUN = selectInput, id = 'linregcontrast',
len = nrow(linRegAllVars$linRegSelectedIndepCatBckgVars), choices = c("Dummy", "Deviation", "Simple"),
width = "100%", selectize = FALSE)

generate.lin.reg.refcat.new.inputs(FUN = selectInput, id = paste0("linregrefcat", i),
choices = file.lin.reg$var.unique.values[linRegAllVars$linRegSelectedIndepCatBckgVars[ , Variables]][i],
width = "100%", selectize = FALSE)

This makes things less complicated and with less coding work that can be prone to error.

Sister

Yes this works, but the dropdown with selectize=TRUE is more stylish. – Lamm