R Shiny DT 回调更新列过滤器不能按预期使用多个表

Question

我一直在为 DT 包中的 R Shiny 数据table 开发回调函数。预期的功能是，当您使用列过滤器更改 table 中存在的行时，其他过滤器应仅显示 table 中实际存在的选项，而不是原始数据集中的选项。

在下面的示例中，您可以查看此行为。在第一个table中，设置N列为0，P列为1，K列为0，然后点击block列的filter，你会看到只显示了2、3、4不出所料。

当我试图将同一个回调函数传递给它下面的 table 时，问题就出现了。我似乎无法弄清楚发生了什么。回调函数（据我所知）正在执行与提供给回调函数的 table 参数相关的所有操作。

对于这方面的任何帮助，我将不胜感激。谢谢！


    library(shiny)
    library(DT)
    library(dplyr)
    
    callback <- c(
      "function onlyUnique(value, index, self) {",
      "   return self.indexOf(value) === index;",
      "};",
      "table_header = table.table().header();",
      "column_nodes = $(table_header).find('tr:nth-child(2) > td');",
      "input_nodes = $(column_nodes).find('input.form-control');",
      "for (let i = 0; i < input_nodes.length; i++){",
      "  data_type_attr = $(input_nodes[i]).closest('td').attr('data-type');",
      "  if (data_type_attr == 'factor'){",
      "     $(input_nodes[i]).on('input propertychange', function(){",
      "        if (typeof unique_values !== 'undefined'){",
      "          selection_content = $(input_nodes[i]).closest('td').find('div.selectize-dropdown-content');",
      "          var content_str = '';",
      "          for (let j = 0; j < unique_values.length; j++){",
      "             content_str = content_str.concat('<div data-value=\"', unique_values[j],'\" data-selectable=\"\" class=\"option\">', unique_values[j], '</div>')",
      "          }",
      "          selection_content[0].innerHTML = content_str;",
      "        }",
      "     })",
      "  }",
      "}",
      "column_nodes.on('click', function(){",
      "setTimeout(function(){",
      "  for (let i = 0; i < column_nodes.length; i++){",
      "    data_type_attr = $(column_nodes[i]).attr('data-type');",
      "    if (data_type_attr == 'factor'){",
      "       selection_div = $(column_nodes[i]).find('div.selectize-input');",
      "       if($(selection_div).hasClass('dropdown-active')){",
      "          values = table.column(i, {pages: 'all', search: 'applied'}).data();",
      "          unique_values = Array.from(values.filter(onlyUnique));",
      "          selection_content = $(column_nodes[i]).find('div.selectize-dropdown-content');",
      "          var content_str = '';",
      "          for (let j = 0; j < unique_values.length; j++){",
      "             content_str = content_str.concat('<div data-value=\"', unique_values[j],'\" data-selectable=\"\" class=\"option\">', unique_values[j], '</div>')",
      "          }",
      "          selection_content[0].innerHTML = content_str;",
      "       }",
      "    }",
      "  }",
      "}, 50);",
      "})"
    )
    # <div data-value="DEO" data-selectable="" class="option">DEO</div>
    #summary_table <- read.csv("summary")[, c("GSN", "Category", "Study.Level", "Planned.Maximum.Age.of.Subjects")] %>% 
    #  mutate_at(c("GSN", "Category", "Study.Level"), as.factor) %>% mutate_at(c("Planned.Maximum.Age.of.Subjects"), as.numeric);
    #summary_table_2 <- summary_table;
    
    ui <- fluidPage(
      DT::dataTableOutput("table_1"),
      DT::dataTableOutput("table_2")
    )
    
    server <- function(input, output){
        output[["table_1"]] <- DT::renderDataTable(
           npk,
           filter = "top",
           server = FALSE, 
           callback = JS(callback));
        
        output[["table_2"]] <- DT::renderDataTable(
          npk,
          filter = "top",
          server = FALSE, 
          callback = JS(callback));
        
        dep <- htmltools::htmlDependency("jqueryui", "1.12.1",
                                         "www/shared/jqueryui",
                                         script = "jquery-ui.min.js",
                                         package = "shiny")
    }
    shinyApp(ui, server)

Answer 1

查看 https://github.com/rstudio/DT/issues/952#issuecomment-1024909574

上的反馈

与DT的回调功能无关。你的问题的原因是你应该用 var x = ... 在 JS 中定义局部变量。定义没有 var 前缀的变量会导致全局变量。所以这两个回调将共享同一个变量。

通过在 table_header、column_nodes 和 input_nodes 之前添加三个 var 可以解决这个问题。

但这还不够，因为 unique_values 也应该小心处理，否则在其他情况下您会遇到其他问题。

library(shiny)
library(DT)

callback <- r"{
function onlyUnique(value, index, self) {
  return self.indexOf(value) === index;
};
var table_header = table.table().header();
var column_nodes = $(table_header).find('tr:nth-child(2) > td');
var input_nodes = $(column_nodes).find('input.form-control');
for (let i = 0; i < input_nodes.length; i++){
  data_type_attr = $(input_nodes[i]).closest('td').attr('data-type');
  if (data_type_attr == 'factor'){
    $(input_nodes[i]).on('input propertychange', function(){
      if (typeof unique_values !== 'undefined'){
        selection_content = $(input_nodes[i]).closest('td').find('div.selectize-dropdown-content');
        var content_str = '';
        for (let j = 0; j < unique_values.length; j++){
          content_str = content_str.concat('<div data-value="', unique_values[j],'" data-selectable="" class="option">', unique_values[j], '</div>')
        }
        selection_content[0].innerHTML = content_str;
      }
    })
  }
}
column_nodes.on('click', function(){
  setTimeout(function(){
    for (let i = 0; i < column_nodes.length; i++){
      data_type_attr = $(column_nodes[i]).attr('data-type');
      if (data_type_attr == 'factor'){
        selection_div = $(column_nodes[i]).find('div.selectize-input');
        if($(selection_div).hasClass('dropdown-active')){
          values = table.column(i, {pages: 'all', search: 'applied'}).data();
          unique_values = Array.from(values.filter(onlyUnique));
          selection_content = $(column_nodes[i]).find('div.selectize-dropdown-content');
          var content_str = '';
          for (let j = 0; j < unique_values.length; j++){
            content_str = content_str.concat('<div data-value="', unique_values[j],'" data-selectable="" class="option">', unique_values[j], '</div>')
          }
          selection_content[0].innerHTML = content_str;
        }
      }
    }
  }, 50);
})
}"

ui <- fluidPage(
  DT::dataTableOutput("table_1"),
  DT::dataTableOutput("table_2")
)

server <- function(input, output){
  output[["table_1"]] <- DT::renderDataTable(
    npk,
    filter = "top",
    server = FALSE, 
    callback = JS(callback))
  
  output[["table_2"]] <- DT::renderDataTable(
    npk,
    filter = "top",
    server = FALSE, 
    callback = JS(callback))

}
shinyApp(ui, server)

R Shiny DT 回调更新列过滤器不能按预期使用多个表

R Shiny DT callback to update column filters not working as expected with multiple tables

javascript

jquery

callback

shiny

dt