从不同来源组装的 Shiny DT 收集所有复选框值时出现问题

Question

很抱歉，可重现的例子不是很简单。

我有一个闪亮的大应用程序，这里的例子只是一个摘录。我正在尝试生成一个带有复选框的 DT table。该应用程序左侧有 DT 个可用值，右侧有三个 DT 个可用值，可以使用按钮移动所选值。

在所有这些下面生成了另外两个 table。第一个使用 reactive 对象，该对象由右上角三个 table 中选择的所有值的唯一组合构成，每对之间都有复选框。第二个 table 也使用 reactive 对象来显示选定的对。当呈现带有复选框的 table 时，一切正常。但是，当我单击复选框时，实际上并非所有复选框都被选中并显示在最后的 DT 输出中。以下是这种不良行为的一些观察模式：

如果右上角第一个（或第二个，或第三个）DT有值只有，一切正常，点击复选框产生所需的结果。
当第一个和第二个 DT 中有选定值时，单击第一个复选框无效。
如果右侧的三个 DT 都有值，那么点击前几个复选框没有任何效果，但对后续有效。

根据右上角三个 DT 输出中所选值的数量，可能存在其他不同的情况。我无法解释为什么没有收集所有复选框值。当使用 shinyInput 函数生成复选框时，它们的数量与所有可能对的数量相匹配。但是，shinyValue 函数只收集其中的一部分。

这是最终输出的屏幕截图，其中选中了所有生成的复选框，但只返回了三对：

这是代码：

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
      ))
    })
  }
)

有人可以帮忙吗？

Answer 1

那是因为您正试图对复选框使用相同的 ID。试试这个

  # 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
      }
    })
  }

从不同来源组装的 Shiny DT 收集所有复选框值时出现问题

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

r

checkbox

shiny

reactive

dt