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

Question

我的 R Shiny 应用程序中有一个使用 DT 包的数据表。该表启用了列过滤器。偶尔，我会使用replaceData函数替换数据表中的数据。发生这种情况时，数据会更新，但列过滤器中的选择仍然反映原始数据的选择。

在下面的示例中，初始数据包含三行，每一行都可以使用任何列过滤器进行过滤。单击“更新数据”按钮会将数据替换为相同的数据，再加上一行。您可以看到 NUMERIC 列的选项仍然只有 1 到 3 而不是 1 到 4，FACTOR 列的选项仍然只提供“A”、“B”和“C”作为选项，但不包括“D”。

根据 replaceData 函数的文档，“启用列过滤器后，还应确保每列的属性保持不变，例如因子列应具有相同或更少的级别，数字列应具有相同或更小的范围，否则过滤器可能永远无法到达数据中的某些行。”所以这是预期的行为，但我想知道是否还有办法更新列过滤器中的选择。我假设没有使用 R 的解决方案，但我希望有一个我可以使用的 javascript 解决方案。我真的不知道 javascript，所以我无法看到 DT 包最初是如何生成列选择的，但如果可能的话，我确实知道如何从闪亮的应用程序调用 javascript 代码。如果没有办法做到这一点，我最后的办法是每次我想替换数据时都重新渲染数据表，但如果没有必要，我宁愿不这样做。

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

从?replaceData可以看到：

当您替换现有表中的数据时，请确保 新数据与当前数据具有相同的列数。当你 已启用列过滤器，您还应该确保属性 每列的保持不变，例如因子列应该有 相同或更少的级别，并且数字列应具有相同或 范围更小，否则过滤器可能永远无法达到 数据中的某些行。

这意味着你只能得到更小的过滤器，而不是更大的。

嗯，这不干净，而是一个肮脏的把戏：

如果你使用trace(datatable, edit=T)，你可以修改函数datatable，所以如果你用原来的代码代替：

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

然后你保存它，你可以看到这样做：

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)

你看到你可以从头开始过滤D和4。 这是一个棘手的废话，我知道。请不要太苛刻地评价我...