Problem collecting all checkbox values from Shiny DT assembled from different sources-CodePudding

I apologize that the reproducible example is not quite minimal.

I have a large shiny app, the example here is just an excerpt. I am trying to produce a DT table with checkboxes. The application has DT of available values on the left and three DT on the right where selected values can be moved with buttons.

Below all these another two tables are generated. The first one uses a reactive object constructed from the unique combinations of all values selected in the three tables on the top right with checkboxes between each pair. The second table also uses a reactive object to display the selected pairs. It all works fine when the table with the checkboxes is rendered. However, when I click on the checkboxes, not all are actually selected and displayed in the last DT output. Here are some observed patterns of this unwanted behavior:

If there are values only in the first (or the second, or the third) DT on the top right, all works fine, clicking on the checkbox produces the desired result.
When there are selected values in the first and the second DTs, then clicking on the first checkbox has no effect.
If there are values in all three DTs on the right, then clicking on the first few checkboxes does not have any effect, but it works for the subsequent.

Different other scenarios are possible, depending on the number of selected values in the three DT outputs on the top right. I can't reach any explanation why not all of the checkbox values are collected. When the checkboxes are generated with the shinyInput function, their number matches the number of all possible pairs. However, the shinyValue function collects just part of them.

Here is a screenshot of the final outputs where all generated checkboxes are checked, but just three pairs are returned:

And here is the code:

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

mydt <- data.table(Variables = c("IDCNTRY", "ASBG01", "ASBG03", "ASBG04", "ASBG05A", "ASBG05B", "ASBG05C", "ASBG05D", "ASBG05E", "ASBG05F", "ASBG05G", "ASBG05H", "ASBG06", "ASBG07A", "ASBG07B", "ASBG08", "ASBG09A", "ASBG09B", "ASBG09C", "ASBG10A", "ASBG10B"),
Variable_Labels = c("COUNTRY ID", "SEX OF STUDENT", "OFTEN SPEAK <LANG OF TEST> AT HOME", "AMOUNT OF BOOKS IN YOUR HOME", "HOME POSSESS/COMPUTER OR TABLET", "HOME POSSESS/STUDY DESK", "HOME POSSESS/OWN ROOM", "HOME POSSESS/INTERNET CONNECTION", "HOME POSSESS/<COUNTRY SPECIFIC>", "HOME POSSESS/<COUNTRY SPECIFIC>", "HOME POSSESS/<COUNTRY SPECIFIC>", "HOME POSSESS/<COUNTRY SPECIFIC>", "ABOUT HOW OFTEN ABSENT FROM SCHOOL", "HOW OFTEN FEEL THIS WAY/TIRED", "HOW OFTEN FEEL THIS WAY/HUNGRY", "HOW OFTEN BREAKFAST ON SCHOOL DAYS", "USE COMPUTER TABLET/HOME", "USE COMPUTER TABLET/SCHOOL", "USE COMPUTER TABLET/OTHER", "USE COMPUTER TABLET SCHOOLWORK/READING", "USE COMPUTER TABLET SCHOOLWORK/PREPARING"),
order_col = 1:21)

shinyApp(
  ui <- fluidPage(
    fluidRow(
      column(width = 6, align = "center",
             DTOutput(outputId = "allAvailableVars"),
      ),
      
      column(width = 6,
             fluidRow(
               column(width = 2, align = "center",
                      br(), br(),  br(),
                      uiOutput(outputId = "arrowSelGroup1VarsRight"),
                      uiOutput(outputId = "arrowSelGroup1VarsLeft")
               ),
               column(width = 10,
                      DTOutput(outputId = "group1Vars")
               )
             ),
             
             fluidRow(
               column(width = 2, align = "center",
                      br(), br(),  br(),
                      uiOutput(outputId = "arrowSelGroup2VarsRight"),
                      uiOutput(outputId = "arrowSelGroup2VarsLeft")
               ),
               column(width = 10,
                      DTOutput(outputId = "group2Vars"),
               ),
               br()
             ),
             
             fluidRow(
               column(width = 2, align = "center",
                      br(), br(),  br(),
                      uiOutput(outputId = "arrowSelGroup3Right"),
                      uiOutput(outputId = "arrowSelGroup3Left")
               ),
               
               column(width = 10,
                      DTOutput(outputId = "group3Vars"),
               )
             )
      )
    ),
    
    fluidRow(
      column(width = 6,
             DTOutput(outputId = "checkBoxTable")
      ),
      column(width = 6,
             DTOutput(outputId = "selectedCheckBoxTable")
      )
    )
  ),
  
  
  server <- function(input, output, session) {
    
    observe({
      
      # Create initial values for the available and selected variables.
      initial.available.vars <- mydt
      initial.selected.split.vars <- data.table(Variables = as.character(), Variable_Labels = as.character(), order_col = as.numeric())
      initial.selected.bckg.vars <- data.table(Variables = as.character(), Variable_Labels = as.character(), order_col = as.numeric())
      initial.selected.PV.vars <- data.table(Variables = as.character(), Variable_Labels = as.character(), order_col = as.numeric())
      initial.checkboxes <- data.table(Variable1 = as.character(), Check = as.character(), Variable2 = as.character())
      
      allVars <- reactiveValues(availVars = initial.available.vars, selectedGroup1Vars = initial.selected.split.vars, selectedGroup2Vars = initial.selected.bckg.vars, selectedGroup3Vars = initial.selected.PV.vars)
      
      output$arrowSelGroup1VarsRight <- renderUI({
        actionButton(inputId = "arrowSelGroup1VarsRight", label = NULL, icon("angle-right"), width = "50px")
      })
      
      output$arrowSelGroup1VarsLeft <- renderUI({
        actionButton(inputId = "arrowSelGroup1VarsLeft", label = NULL, icon("angle-left"), width = "50px")
      })
      
      output$arrowSelGroup2VarsRight <- renderUI({
        actionButton(inputId = "arrowSelGroup2VarsRight", label = NULL, icon("angle-right"), width = "50px")
      })
      
      output$arrowSelGroup2VarsLeft <- renderUI({
        actionButton(inputId = "arrowSelGroup2VarsLeft", label = NULL, icon("angle-left"), width = "50px")
      })
      
      output$arrowSelGroup3Right <- renderUI({
        actionButton(inputId = "arrowSelGroup3Right", label = NULL, icon("angle-right"), width = "50px")
      })
      
      output$arrowSelGroup3Left <- renderUI({
        actionButton(inputId = "arrowSelGroup3Left", label = NULL, icon("angle-left"), width = "50px")
      })
      
      observeEvent(input$arrowSelGroup1VarsRight, {
        req(input$allAvailableVars_rows_selected)
        allVars$selectedGroup1Vars <- rbind(isolate(allVars$selectedGroup1Vars), allVars$availVars[input$allAvailableVars_rows_selected, , drop = FALSE])
        allVars$selectedGroup1Vars <- allVars$selectedGroup1Vars[complete.cases(allVars$selectedGroup1Vars[ , "Variables"]), , drop = FALSE]
        allVars$availVars <- isolate(allVars$availVars[-input$allAvailableVars_rows_selected, , drop = FALSE])
      })
      
      observeEvent(input$arrowSelGroup1VarsLeft, {
        req(input$group1Vars_rows_selected)
        allVars$availVars <- rbind(isolate(allVars$availVars), allVars$selectedGroup1Vars[input$group1Vars_rows_selected, , drop = FALSE])
        allVars$availVars <- allVars$availVars[complete.cases(allVars$availVars[ , "Variables"]), , drop = FALSE]
        allVars$selectedGroup1Vars <- isolate(allVars$selectedGroup1Vars[-input$group1Vars_rows_selected, , drop = FALSE])
      })
      
      observeEvent(input$arrowSelGroup2VarsRight, {
        req(input$allAvailableVars_rows_selected)
        allVars$selectedGroup2Vars <- rbind(isolate(allVars$selectedGroup2Vars), allVars$availVars[input$allAvailableVars_rows_selected, , drop = FALSE])
        allVars$selectedGroup2Vars <- allVars$selectedGroup2Vars[complete.cases(allVars$selectedGroup2Vars[ , "Variables"]), , drop = FALSE]
        allVars$availVars <- isolate(allVars$availVars[-input$allAvailableVars_rows_selected, , drop = FALSE])
      })
      
      observeEvent(input$arrowSelGroup2VarsLeft, {
        req(input$group2Vars_rows_selected)
        allVars$availVars <- rbind(isolate(allVars$availVars), allVars$selectedGroup2Vars[input$group2Vars_rows_selected, , drop = FALSE])
        allVars$availVars <- allVars$availVars[complete.cases(allVars$availVars[ , "Variables"]), , drop = FALSE]
        allVars$selectedGroup2Vars <- isolate(allVars$selectedGroup2Vars[-input$group2Vars_rows_selected, , drop = FALSE])
      })
      
      observeEvent(input$arrowSelGroup3Right, {
        req(input$allAvailableVars_rows_selected)
        allVars$selectedGroup3Vars <- rbind(isolate(allVars$selectedGroup3Vars), allVars$availVars[input$allAvailableVars_rows_selected, , drop = FALSE])
        allVars$selectedGroup3Vars <- allVars$selectedGroup3Vars[complete.cases(allVars$selectedGroup3Vars[ , "Variables"]), , drop = FALSE]
        allVars$availVars <- isolate(allVars$availVars[-input$allAvailableVars_rows_selected, , drop = FALSE])
      })
      
      observeEvent(input$arrowSelGroup3Left, {
        req(input$group3Vars_rows_selected)
        allVars$availVars <- rbind(isolate(allVars$availVars), allVars$selectedGroup3Vars[input$group3Vars_rows_selected, , drop = FALSE])
        allVars$availVars <- allVars$availVars[complete.cases(allVars$availVars[ , "Variables"]), , drop = FALSE]
        allVars$selectedGroup3Vars <- isolate(allVars$selectedGroup3Vars[-input$group3Vars_rows_selected, , drop = FALSE])
      })
      
      output$allAvailableVars <- renderDT({
        setkeyv(x = allVars$availVars, cols = "order_col")
      },
      rownames = FALSE, colnames = c("Names", "Labels", "sortingcol"), extensions = list("Scroller"),
      options = list(dom = "ti", ordering = FALSE, autoWidth = TRUE, pageLength = 5000, deferRender = TRUE, scrollY = 455, scroller = TRUE))
      
      output$group1Vars <- renderDT({
        allVars$selectedGroup1Vars
      },
      rownames = FALSE, colnames = c("Names", "Labels", "sortingcol"), extensions = list("Scroller"),
      options = list(dom = "ti", ordering = FALSE, pageLength = 5000, autoWidth = TRUE, deferRender = TRUE, scrollY = 100, scroller = TRUE))
      
      output$group2Vars <- renderDT({
        allVars$selectedGroup2Vars
      },
      rownames = FALSE, class = "cell-border stripe;compact cell-border;", extensions = list("Scroller"),
      options = list(dom = "ti", ordering = FALSE, pageLength = 5000, autoWidth = TRUE, deferRender = TRUE, scrollY = 100, scroller = TRUE))
      
      output$group3Vars <- renderDT({
        allVars$selectedGroup3Vars
      },
      rownames = FALSE, class = "cell-border stripe;compact cell-border;", extensions = list("Scroller"),
      options = list(dom = "ti", ordering = FALSE, pageLength = 5000, autoWidth = TRUE, rowCallback = JS("function(r,d) {$(r).attr('height', '40px')}"), deferRender = TRUE, scrollY = 100, scroller = TRUE))
      
      # Define a function to generate the checkboxes in the table.
      shinyInput = function(FUN, len, id, ...) {
        inputs <- character(len)
        lapply(seq_len(len), function(i) {
          inputs[i] <- as.character(FUN(paste0(id, i), label = NULL, ...))
        })
      }
      
      # Define a function to read back the input from the checkboxes.
      shinyValue <- function(id, len) {
        sapply(seq_len(len), function(i) {
          value <- input[[paste0(id, i)]]
          if(is.null(value)) {
            NA
          } else {
            value
          }
        })
      }
      
      # Combine a data.table with the unique combinations of the selected variables.
      possibleCheckboxes <- reactive({
        if(nrow(rbindlist(l = list(allVars$selectedGroup1Vars, allVars$selectedGroup2Vars, allVars$selectedGroup3Vars))) > 1) {
          selected.vars <- c(allVars$selectedGroup1Vars[ , Variables], allVars$selectedGroup2Vars[ , Variables], allVars$selectedGroup3Vars[ , Variables])
          tmp <- transpose(as.data.table(combn(x = selected.vars, m = 2)))
          data.table(Variable1 = tmp[ , V1], Check = shinyInput(FUN = checkboxInput, len = nrow(tmp), id = "cbox_", width = "5px"), Variable2 = tmp[ , V2])
        } else {
          initial.checkboxes
        }
      })
      
      # Render the data table for the checkboxes.
      output$checkBoxTable <- renderDT({
        possibleCheckboxes()
      },
      server = FALSE, escape = FALSE, rownames = FALSE, colnames = c("Variable 1", "", "Variable 2"), extensions = list("Scroller"), selection="none",
      options = list(dom = "ti", ordering = FALSE, autoWidth = TRUE, preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'), drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '), deferRender = TRUE, scrollY = 450, scroller = TRUE))
      
      selectedCheckboxes <- reactive({
        if(nrow(possibleCheckboxes()) > 0) {
          possibleCheckboxes()[shinyValue(id = "cbox_", len = nrow(possibleCheckboxes())) == TRUE]
        } else {
          initial.checkboxes
        }
      })
      
      output$selectedCheckBoxTable <- renderDT({
        selectedCheckboxes()[ , mget(c("Variable1", "Variable2"))]
      },
      server = FALSE, escape = FALSE, rownames = FALSE, colnames = c("Variable 1", "Variable 2"), extensions = list("Scroller"), selection="none",
      options = list(dom = "ti",
                     ordering = FALSE,
                     autoWidth = TRUE,
                     preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                     drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '),
                     deferRender = TRUE, scrollY = 450, scroller = TRUE
      ))
    })
  }
)

Can someone help with this?

CodePudding user response：

That is because you are trying to use the same ID for checkboxes. Try this

  # Define a function to generate the checkboxes in the table.
  shinyInput = function(FUN, len, id, ...) {
    inputs <- character(len)
    lapply(seq_len(len), function(i) {
      inputs[i] <- as.character(FUN(paste0(id, len, i), label = NULL, ...))
    })
  }
  
  # Define a function to read back the input from the checkboxes.
  shinyValue <- function(id, len) {
    sapply(seq_len(len), function(i) {
      value <- input[[paste0(id, len, i)]]
      
      if(is.null(value)) {
        NA
      } else {
        value
      }
    })
  }