Adapt/update filter choices to already applied filters in shiny DT datatable

Question

I am using the package DT to display a table in r shiny. When I apply a filter in one column the filter choices of the other columns don´t adapt to the already filtered table. So in the example below if you filter sepal.length with 4.3 ... 4.8 you still get the option to filter species "virginica" even when there is no entry that has sepal.length between 4.3 and 4.8 and is "virginica". This is especially troublesome when you want to filter factor columns with more than 100 levels.

To this problem there is already a solution written in JavaScript. See this link: https://datatables.net/forums/discussion/27541/update-select-filters and a live demo of the solution: http://live.datatables.net/xehimatu/1/edit However I don´t know how to implement this in shiny.

Here is a small example with the Iris dataset.

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)

How do I adapt the JavaScript Code to get this function working in Shiny and where do I insert the code snippet.

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

Help would be really appreciated.

Answer 1

You can run JavaScript code in your shiny app by different packages such as htmlwidgets , shinyjs and etc. For your problem , you can include the JavaScript into a text file on your server.R. I suggest a generic solution for updating of the filters below :

In your Server.R file:

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

The script above is updating the reaming filter options upon selecting different filters from other columns. Now you can use it in the DT package in the DT::renderDataTable function and pass the script above to the callback argument. Make sure you pass server = FALSE as the other argument if you want the applied filter on the whole table, not just the rendered one.

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

You can also look at the Rstudio documentations: https://shiny.rstudio.com/articles/packaging-javascript.html

Answer 2

I found the following example with another functionality (Row details). I will try to follow the same logic (although I am not experienced with JS). If you manage to make it, please let us know:

HTML plus Javascript https://datatables.net/examples/api/row_details.html

The same but implemented inside R https://rstudio.github.io/DT/002-rowdetails.html