更新 R Shiny 中的 DT 列过滤器选项

Question

I have a data table in my R Shiny app using the DT package. The table has column filters enabled. Occasionally, I will replace the data in the data table using the replaceData function. When this happens, the data is updated, but the choices in the column filter still reflect the choices for the original data.

In the below example, the initial data has three rows, each of which can be filtered to by using any of the column filters. Clicking the "Update Data" button replaces the data with the same data, plus an additional row. You can see that the choices for the NUMERIC column still only range from 1 to 3 instead of 1 to 4 and the choices for the FACTOR column still only gives "A", "B", and "C" as choices but does not include "D".

According to the documentation for the replaceData function, "When you have enabled column filters, you should also make sure the attributes of every column remain the same, eg factor columns should have the same or fewer levels, and numeric columns should have the same or smaller range, otherwise the filters may never be able to reach certain rows in the data." So this is the expected behavior, but I'm wondering if there's still a way to update the choices in the column filters. I assume there's no solution using R, but I'm hoping there's a javascript solution I could use. I don't really know javascript, so I wasn't able to see how the DT package generates column choices initially, but if it's possible, I do know how to call javascript code from the shiny app. If there's no way to do this, my last resort would be to just rerender the data table every time I want to replace the data, but I'd rather not do that if I don't have to.

library(shiny)
library(DT)

ui <- fluidPage(
  fluidRow(DTOutput("table")),
  fluidRow(actionButton("replace", "Replace Data"))
)

server <- function(input, output, session) {

  output$table <- renderDT({
    data <- data.frame(NUMERIC = c(1, 2, 3), FACTOR = as.factor(c("A", "B", "C")), TEXT = c("A1", "B2", "C3"), stringsAsFactors = FALSE)
    datatable(data, filter = list(position = "top"))
  })

  observeEvent(input$replace, {
    data <- data.frame(NUMERIC = c(1, 2, 3, 4), FACTOR = as.factor(c("A", "B", "C", "D")), TEXT = c("A1", "B2", "C3", "D4"), stringsAsFactors = FALSE)
    replaceData(proxy = dataTableProxy("table"), data = data)
  })

}

shinyApp(ui = ui, server = server)

Answer 1

As you can see from ?replaceData :

When you replace the data in an existing table, please make sure the new data has the same number of columns as the current data. When you have enabled column filters, you should also make sure the attributes of every column remain the same, eg factor columns should have the same or fewer levels, and numeric columns should have the same or smaller range, otherwise the filters may never be able to reach certain rows in the data.

It means that you can only get smaller filters, not bigger.

Well, this is not clean but a dirty trick:

If you use trace(datatable, edit=T) you can modify the function datatable so if you substitute the original code for this:

function (data, options = list(), class = "display", callback = JS("return table;"), 
  rownames, colnames, container, caption = NULL, filter = c("none", 
    "bottom", "top"), escape = TRUE, style = "default", 
  width = NULL, height = NULL, elementId = NULL, fillContainer = getOption("DT.fillContainer", 
    NULL), autoHideNavigation = getOption("DT.autoHideNavigation", 
    NULL), selection = c("multiple", "single", "none"), 
  extensions = list(), plugins = NULL, editable = FALSE) 
{
  datafull = data[[2]]
  data = data[[1]]
  oop = base::options(stringsAsFactors = FALSE)
  on.exit(base::options(oop), add = TRUE)
  options = modifyList(getOption("DT.options", list()), if (is.function(options)) 
    options()
  else options)
  params = list()
  if (crosstalk::is.SharedData(data)) {
    params$crosstalkOptions = list(key = data$key(), group = data$groupName())
    data = data$data(withSelection = FALSE, withFilter = TRUE, 
      withKey = FALSE)
    datafull = data$data(withSelection = FALSE, withFilter = TRUE, 
      withKey = FALSE)
  }
  rn = if (missing(rownames) || isTRUE(rownames)) 
    base::rownames(data)
  else {
    if (is.character(rownames)) 
      rownames
  }
  hideDataTable = FALSE
  if (is.null(data) || identical(ncol(data), 0L)) {
    data = matrix(ncol = 0, nrow = NROW(data))
    datafull = matrix(ncol = 0, nrow = NROW(datafull))
    hideDataTable = TRUE
  }
  else if (length(dim(data)) != 2) {
    str(data)
    stop("'data' must be 2-dimensional (e.g. data frame or matrix)")
  }
  if (is.data.frame(data)) {
    data = as.data.frame(data)
    numc = unname(which(vapply(data, is.numeric, logical(1))))
  }
  else {
    if (!is.matrix(data)) 
      stop("'data' must be either a matrix or a data frame, and cannot be ", 
        classes(data), " (you may need to coerce it to matrix or data frame)")
    numc = if (is.numeric(data)) 
      seq_len(ncol(data))
    data = as.data.frame(data)
  }
  if (!is.null(rn)) {
    data = cbind(` ` = rn, data)
    datafull = cbind(` ` = rn, datafull)
    numc = numc + 1
  }
  if (length(numc)) {
    undefined_numc = setdiff(numc - 1, classNameDefinedColumns(options))
    if (length(undefined_numc)) 
      options = appendColumnDefs(options, list(className = "dt-right", 
        targets = undefined_numc))
  }
  if (is.null(options[["order"]])) 
    options$order = list()
  if (is.null(options[["autoWidth"]])) 
    options$autoWidth = FALSE
  if (is.null(options[["orderClasses"]])) 
    options$orderClasses = FALSE
  cn = base::colnames(data)
  if (missing(colnames)) {
    colnames = cn
  }
  else if (!is.null(names(colnames))) {
    i = convertIdx(colnames, cn)
    cn[i] = names(colnames)
    colnames = cn
  }
  if (ncol(data) - length(colnames) == 1) 
    colnames = c(" ", colnames)
  if (length(colnames) && colnames[1] == " ") 
    options = appendColumnDefs(options, list(orderable = FALSE, 
      targets = 0))
  style = match.arg(tolower(style), DTStyles())
  if (style == "bootstrap") 
    class = DT2BSClass(class)
  if (style != "default") 
    params$style = style
  if (isTRUE(fillContainer)) 
    class = paste(class, "fill-container")
  if (is.character(filter)) 
    filter = list(position = match.arg(filter))
  filter = modifyList(list(position = "none", clear = TRUE, 
    plain = FALSE), filter)
  filterHTML = as.character(filterRow(datafull, !is.null(rn) && 
    colnames[1] == " ", filter))
  if (filter$position == "top") 
    options$orderCellsTop = TRUE
  params$filter = filter$position
  if (filter$position != "none") 
    params$filterHTML = filterHTML
  if (missing(container)) {
    container = tags$table(tableHeader(colnames, escape), 
      class = class)
  }
  else {
    params$class = class
  }
  attr(options, "escapeIdx") = escapeToConfig(escape, colnames)
  if (is.list(extensions)) {
    extensions = names(extensions)
  }
  else if (!is.character(extensions)) {
    stop("'extensions' must be either a character vector or a named list")
  }
  params$extensions = if (length(extensions)) 
    as.list(extensions)
  if ("Responsive" %in% extensions) 
    options$responsive = TRUE
  params$caption = captionString(caption)
  if (editable) 
    params$editable = editable
  if (!identical(class(callback), class(JS("")))) 
    stop("The 'callback' argument only accept a value returned from JS()")
  if (length(options$pageLength) && length(options$lengthMenu) == 
    0) {
    if (!isFALSE(options$lengthChange)) 
      options$lengthMenu = sort(unique(c(options$pageLength, 
        10, 25, 50, 100)))
    if (identical(options$lengthMenu, c(10, 25, 50, 100))) 
      options$lengthMenu = NULL
  }
  if (!is.null(fillContainer)) 
    params$fillContainer = fillContainer
  if (!is.null(autoHideNavigation)) 
    params$autoHideNavigation = autoHideNavigation
  params = structure(modifyList(params, list(data = data, 
    container = as.character(container), options = options, 
    callback = if (!missing(callback)) JS("function(table) {", 
      callback, "}"))), colnames = cn, rownames = length(rn) > 
    0)
  if (inShiny() || length(params$crosstalkOptions)) {
    if (is.character(selection)) {
      selection = list(mode = match.arg(selection))
    }
    selection = modifyList(list(mode = "multiple", selected = NULL, 
      target = "row"), selection)
    if (grepl("^row", selection$target) && is.character(selection$selected) && 
      length(rn)) {
      selection$selected = match(selection$selected, rn)
    }
    params$selection = selection
  }
  deps = list(DTDependency(style))
  deps = c(deps, unlist(lapply(extensions, extDependency, 
    style, options), recursive = FALSE))
  if (params$filter != "none") 
    deps = c(deps, filterDependencies())
  if (isTRUE(options$searchHighlight)) 
    deps = c(deps, list(pluginDependency("searchHighlight")))
  if (length(plugins)) 
    deps = c(deps, lapply(plugins, pluginDependency))
  deps = c(deps, crosstalk::crosstalkLibs())
  if (isTRUE(fillContainer)) {
    width = NULL
    height = NULL
  }
  htmlwidgets::createWidget("datatables", if (hideDataTable) 
    NULL
  else params, package = "DT", width = width, height = height, 
    elementId = elementId, sizingPolicy = htmlwidgets::sizingPolicy(knitr.figure = FALSE, 
      knitr.defaultWidth = "100%", knitr.defaultHeight = "auto"), 
    dependencies = deps, preRenderHook = function(instance) {
      data = instance[["x"]][["data"]]
      if (object.size(data) > 1500000 && getOption("DT.warn.size", 
        TRUE)) 
        warning("It seems your data is too big for client-side DataTables. You may ", 
          "consider server-side processing: https://rstudio.github.io/DT/server.html")
      data = escapeData(data, escape, colnames)
      data = unname(data)
      instance$x$data = data
      instance
    })
}

And you save it, you can see that doing this:

library(shiny)
library(data.table)
library(DT)

ui <- fluidPage(
  fluidRow(DTOutput("table")),
  fluidRow(actionButton("replace", "Replace Data"))
)

server <- function(input, output, session) {

  output$table <- renderDT({
    data <- data.table(NUMERIC = c(1, 2, 3), FACTOR = as.factor(c("A", "B", "C")), TEXT = c("A1", "B2", "C3"), stringsAsFactors = FALSE)
    datafull <- data.table(NUMERIC = c(1, 2, 3, 4), FACTOR = as.factor(c("A", "B", "C", "D")), TEXT = c("A1", "B2", "C3", "D4"), stringsAsFactors = FALSE)
    datatable(list(data,datafull), filter = list(position = "top"))


  })

  observeEvent(input$replace, {
    data <- data.frame(NUMERIC = c(1, 2, 3, 4), FACTOR = as.factor(c("A", "B", "C", "D")), TEXT = c("A1", "B2", "C3", "D4"), stringsAsFactors = FALSE)
    replaceData(proxy = dataTableProxy("table"), data = data)
  })

}

shinyApp(ui = ui, server = server)

You see that you can filter D and 4 from the beginning. It is a tricky piece of crap, I know. Please, dont judge me very harshly...