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

Question

I've been working on a callback function for an R Shiny datatable from the DT package. The expected functionality is that when you use the column filters to change what rows are present in the table, the other filters should only show the options actually present in the table rather than those from the original dataset.

In the example below, you can view this behaviour. In the first table, set the N column to 0, the P column to 1 and the K column to 0 and then click the filter in the block column and you'll see it only shows the 2, 3 and 4 as expected.

The problem arises when I attempt to pass this same callback function to the table below it. I can't seem to figure out whats going on. The callback function (to my knowledge) is performing all of its actions relative to the table parameter given to the callback function.

I would appreciate any help on this. Thank you!


    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('', unique_values[j], '')",
      "          }",
      "          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('', unique_values[j], '')",
      "          }",
      "          selection_content[0].innerHTML = content_str;",
      "       }",
      "    }",
      "  }",
      "}, 50);",
      "})"
    )
    # DEO
    #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)

RESOLUTION

Many months later and we have a solution that is robust and requires little amendments to our existing code. It has been adapted from a solution here. Thanks to ismirsehregal for pointing me to the github thread.

You can add the following code to your own project in the server function, being sure to replace "table_id" with your table id and "[TABLE DATA FRAME]" with the data frame used for your table:

      # update filter dropdowns
  filterable_sets <- eventReactive(input$table_id_search_columns, {
    # Get seperarte filtered indices
    fi <- Map(doColumnSearch, [TABLE DATA FRAME], input$table_id_search_columns);
    
    # Find what rows others leave available
    ai <- lapply(seq_along(fi), function(j) Reduce(intersect, fi[-j]));
    
    # Get the corresponding data
    lapply(Map(`[`, [TABLE DATA FRAME], ai), function(x){
      if (is.factor(x)) droplevels(x) else x
    })
  })
  
  # update the columns filters
  proxy <- dataTableProxy("table_id")
  observeEvent(filterable_sets(), {
    updateFilters(proxy, filterable_sets())
  })

Shrek Tan · Accepted Answer

See the feedback on https://github.com/rstudio/DT/issues/952#issuecomment-1024909574

It has nothing to do with DT's callback functionality. The cause of your issue is that you should have defined local variables in JS with var x = .... Defining variables without the var prefix leads to a global variable. So the two callbacks will share the same variable.

By adding three var before table_header, column_nodes and input_nodes fixes this case.

But this is not enough as the unique_values should be carefully handled as well or you would face other issues in other cases.

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('', unique_values[j], '')
        }
        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('', unique_values[j], '')
          }
          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 callback to update column filters not working as expected with multiple tables

RESOLUTION

Answers (1)

Related Questions