闪亮的 DT 单元格下拉菜单的值不会更新，也不会再收集

问题描述 投票：0回答：1

我有一个闪亮的大型应用程序，其中有很多 DT。其中一个 DT 是动态的，并通过用户交互从另一个 DT 获取输入。添加行时，会在内部创建两个下拉列表。这些下拉列表根据变量属性获取值并提供文本输出（请参见下面的示例）。当更改下拉列表的选定类别时，文本输出也会发生变化。一切都工作得很好。然而，上周我注意到输出仅是 

NA
，并且当从下拉列表中选择值时没有任何变化，反应值也没有更新（尝试将它们直接从代码打印到 Rstudio 控制台）。

我用于开发的计算机运行的是带有 R 4.3.2、shiny 1.8.0 和 DT 0.31 的 Linux。我尝试在用于测试的另一台机器上重现该问题。它支持 Windows 10，也带有 R 4.3.2，但闪亮的是 1.7.5.1，DT 是 0.30。在测试机器上，下面的示例完美运行。根据闪亮的变更日志，版本 1.8.0 带来了重大更改。我个人无法判断这是否是我的应用程序不再按预期工作的原因。变更日志提供的如何避免异步执行的解释不是我个人能够理解的。

编辑：我已经在另一台装有Shiny 1.8.0和DT 0.31的Windows 10机器上测试了它，它也在那里失败了。

我检查过 SO 上有一些类似的示例，在发布时它们甚至被标记为可接受的解决方案，但是当现在尝试运行它们时，它们不再按预期运行。例如，“这个”和“这个”。此外，shiny 的 GitHub 页面上的问题中也指出了类似的问题，例如 #3965，可能还有 #3979。 这是我使用的数据： 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"))

这是（不是那么）最小的可重现示例：

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


您必须获取
select(ize)Input
r shiny drop-down-menu reactive dt
1个回答
0
投票

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

然后，您必须在 UI 中的任何位置包含这些依赖项，如下所示：


tagList(deps)



现在您必须初始化表中包含的
selectInput
：


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

也许你可以这样做（我没有尝试）：


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



现在应该可以了。

    



      

      
    

  

  

    
最新问题


  





  

    © www.soinside.com 2019 - 2024. All rights reserved.