更新 R Shiny 中的 DT 列过滤器选择
Posted
技术标签:
【中文标题】更新 R Shiny 中的 DT 列过滤器选择【英文标题】：Update DT column filter choices in R Shiny 【发布时间】：2019-07-17 17:29:27 【问题描述】：我的 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)
【问题讨论】：
【参考方案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。
这是一个棘手的废话，我知道。请不要太苛刻地评价我...
【讨论】：
感谢您的回复。我绝对不介意使用不是最干净的东西。但实际上，我不会预先知道替换数据会是什么样子，因为它会更改很多次，并且每次都可能完全不同。我也不希望过滤器包含表中当前数据中不可用的选项。所以不幸的是，我认为这不会完全按照我的需要工作。但我非常感谢这个建议。以上是关于更新 R Shiny 中的 DT 列过滤器选择的主要内容，如果未能解决你的问题，请参考以下文章
R Shiny，调用模块中的 DT::replaceData 不起作用
R Shiny，在调用模块中的DT :: replaceData不起作用