javascript - 将过滤器选择调整/更新为 Shiny 的 DT 数据表中已应用的过滤器

Question

我正在使用 DT 包在 rshiny 中显示表格。当我在一列中应用过滤器时，其他列的过滤器选择不会适应已过滤的表。因此，在下面的示例中，如果您使用 4.3 ... 4.8 过滤 sepal.length，即使没有 sepal.length 介于 4.3 和 4.8 之间且为“virginica”的条目，您仍然可以选择过滤物种“virginica”。当您想要过滤超过 100 个级别的因子列时，这尤其麻烦。

对于这个问题，已经有一个用 JavaScript 编写的解决方案。请参阅此链接:https://datatables.net/forums/discussion/27541/update-select-filters 以及解决方案的现场演示:http://live.datatables.net/xehimatu/1/edit 但是我不知道如何在 Shiny 中实现这一点。

这是 Iris 数据集的一个小示例。

library(shiny)
library(DT)

ui <- fluidPage(
  fluidRow(column(12, DTOutput("table"))
  )
)

server <- function(input, output, session) {
  output$table <- renderDT({

    DT::datatable(iris, filter = "top")
  })
}

shinyApp(ui, server)

如何调整 JavaScript 代码以使该函数在 Shiny 中工作以及在哪里插入代码片段。

# function of the live demo in the link above

$(document).ready(function() {
  var table = $('#example').DataTable( {
    initComplete: function () {
      this.api().columns().every( function () {
        var column = this;
        var select = $('<select><option value=""></option></select>')
          .appendTo( $(column.footer()).empty() )
          .on( 'change', function () {
            var val = $.fn.dataTable.util.escapeRegex(
              $(this).val()
            );

            column
              .search( val ? '^'+val+'$' : '', true, false )
              .draw();
          } );

        column.data().unique().sort().each( function ( d, j ) {
          select.append( '<option value="'+d+'">'+d+'</option>' );
        } );
      } );
    }
  } );

  table.on('draw', function () {
    table.columns().indexes().each( function ( idx ) {
      var select = $(table.column( idx ).footer()).find('select');

      if ( select.val() === '' ) {
        select
          .empty()
          .append('<option value=""/>');

        table.column(idx, {search:'applied'}).data().unique().sort().each( function ( d, j ) {
          select.append( '<option value="'+d+'">'+d+'</option>' );
        } );
      }
    } );
  } );
} );

非常感谢您的帮助。

Answer 1

您可以通过不同的包在您的 Shiny 应用程序中运行 JavaScript 代码，例如 htmlwidgets 、 shinyjs 等。 对于您的问题，您可以将 JavaScript 包含到 server.R 上的文本文件中。 我建议使用以下通用解决方案来更新过滤器:

在您的 Server.R 文件中:

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

上面的脚本在从其他列中选择不同的过滤器时更新铰孔过滤器选项。 现在，您可以在 DT::renderDataTable 函数中的 DT 包中使用它，并将上面的脚本传递给 callback 参数。如果您希望在整个表格上应用过滤器，而不仅仅是渲染的表格，请确保传递 server = FALSE 作为另一个参数。

server <- function(input, output) {


  output$ex1 <- DT::renderDataTable(
    data.frame(lapply(iris,as.factor)), options = list(pageLength = 25),
                  filter = "top",
                  callback = htmlwidgets::JS(callback)
                  )
  
  
}

ui <- navbarPage(
  title = 'DataTable Options',
  tabPanel('Display length',     DT::dataTableOutput('ex1'))
)

您还可以查看 Rstudio 文档:https://shiny.rstudio.com/articles/packaging-javascript.html