使用下拉选择编辑闪亮的数据表（对于 DT v0.19）
Posted
技术标签:
【中文标题】使用下拉选择编辑闪亮的数据表（对于 DT v0.19）【英文标题】：Edit datatable in shiny with dropdown selection (for DT v0.19) 【发布时间】：2021-12-25 19:03:00 【问题描述】：我将下面的代码基于 Stephane Laurent 对 Stack Overflow 上以下问题的解决方案：
Edit datatable in Shiny with dropdown selection for factor variables
我在代码中添加了使用 editData 来更新表格并能够保存/导出更新。
以下适用于 DT v0.18，但使用 DT v0.19 我发现 id_cell_edit 似乎没有触发。我不确定它是否与回调有关，或者可能与 jquery.contextMenu 有关，因为 DT v0.19 已升级到 jquery 3.0。希望人们对如何解决这个问题有任何见解。
这是我在使用 v0.18 时观察到的行为的描述。当我选择使用列并将第一行的值从默认的“sel”更新为“id”时，DT 表中的值会发生变化。我还看到它更新了 tibble 的视图，因此下载的 csv 文件中的数据也被更新了。如果我进入下一页查看第 11 项，然后返回第一页，我可以看到我更新的记录仍然显示“id”。
这是我在使用 v0.19 时观察到的行为的描述。当我选择使用列并将第一行的值从默认的“sel”更新为“id”时，DT 表中的值会发生变化。它不会更新 tibble 的视图，因此下载的 csv 文件中的数据不会更新。如果我进入下一页查看第 11 项，然后返回第一页，我所做的更新将被清除。
请注意，我还使用 reactlog 运行反应图。我按照相同的步骤将第一行的使用列更新为“id”。我注意到的第一个区别是，当我使用 v0.18 版本时，第 5 步的 reactiveValues###$dt 给了我一个 7 的列表，而当我使用 v0.19 版本时，我给出了一个 8 的列表。在第 16 步，对于 v0.18，input$dt_cell_edit 无效，然后 Data 无效并且 output$table 无效。然而，在使用 v0.19 时的第 16 步，output$dt 无效，然后 output$table 无效。换句话说，当使用 v0.19 时 input$dt_cell_edit 和 Data 不会失效。
library(shiny)
library(DT)
library(dplyr)
cars_df <- mtcars
cars_meta <- dplyr::tibble(variables = names(cars_df), data_class = sapply(cars_df, class), usage = "sel")
cars_meta$data_class <- factor(cars_meta$data_class, c("numeric", "character", "factor", "logical"))
cars_meta$usage <- factor(cars_meta$usage, c("id", "meta", "demo", "sel", "text"))
callback <- c(
"var id = $(table.table().node()).closest('.datatables').attr('id');",
"$.contextMenu(",
" selector: '#' + id + ' td.factor input[type=text]',",
" trigger: 'hover',",
" build: function($trigger, e)",
" var levels = $trigger.parent().data('levels');",
" if(levels === undefined)",
" var colindex = table.cell($trigger.parent()[0]).index().column;",
" levels = table.column(colindex).data().unique();",
" ",
" var options = levels.reduce(function(result, item, index, array)",
" result[index] = item;",
" return result;",
" , );",
" return ",
" autoHide: true,",
" items: ",
" dropdown: ",
" name: 'Edit',",
" type: 'select',",
" options: options,",
" selected: 0",
" ",
" ,",
" events: ",
" show: function(opts)",
" opts.$trigger.off('blur');",
" ,",
" hide: function(opts)",
" var $this = this;",
" var data = $.contextMenu.getInputValues(opts, $this.data());",
" var $input = opts.$trigger;",
" $input.val(options[data.dropdown]);",
" $input.trigger('change');",
" ",
" ",
" ;",
" ",
");"
)
createdCell <- function(levels)
if(missing(levels))
return("function(td, cellData, rowData, rowIndex, colIndex)")
quotedLevels <- toString(sprintf("\"%s\"", levels))
c(
"function(td, cellData, rowData, rowIndex, colIndex)",
sprintf(" $(td).attr('data-levels', '[%s]');", quotedLevels),
""
)
ui <- fluidPage(
tags$head(
tags$link(
rel = "stylesheet",
href = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.8.0/jquery.contextMenu.min.css"
),
tags$script(
src = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.8.0/jquery.contextMenu.min.js"
)
),
DTOutput("dt"),
br(),
verbatimTextOutput("table"),
br(),
downloadButton('download',"Download the data")
)
server <- function(input, output)
dat <- cars_meta
value <- reactiveValues()
value$dt<-
datatable(
dat, editable = "cell", callback = JS(callback),
options = list(
columnDefs = list(
list(
targets = 2,
className = "factor",
createdCell = JS(createdCell(c(levels(cars_meta$data_class), "another level")))
),
list(
targets = 3,
className = "factor",
createdCell = JS(createdCell(c(levels(cars_meta$usage), "another level")))
)
)
)
)
output[["dt"]] <- renderDT(
value$dt
,
server = TRUE)
Data <- reactive(
info <- input[["dt_cell_edit"]]
if(!is.null(info))
info <- unique(info)
info$value[info$value==""] <- NA
dat <- editData(dat, info, proxy = "dt")
dat
)
#output table to be able to confirm the table updates
output[["table"]] <- renderPrint(Data())
output$download <- downloadHandler(
filename = function()"Data.csv",
content = function(fname)
write.csv(Data(), fname)
)
shinyApp(ui, server)
下面我在我的用例中使用了ismirsehregal's solution。我还添加了 renderPrint/verbatimTextOutput 来说明我要对基础数据做什么。我希望能够捕获值而不是输入容器。本质上，我试图给用户一个数据集的代码，允许他们更改一些值，但通过下拉菜单限制选择，然后使用更新的数据集进行进一步处理。在解决方案的这一点上，我不知道如何获取更新的数据集，以便可以使用它，例如导出到 csv 文件。
library(DT)
library(shiny)
library(dplyr)
cars_df <- mtcars
selectInputIDa <- paste0("sela", 1:length(cars_df))
selectInputIDb <- paste0("selb", 1:length(cars_df))
initMeta <- dplyr::tibble(
variables = names(cars_df),
data_class = sapply(selectInputIDa, function(x)as.character(selectInput(inputId = x, label = "", choices = c("character","numeric", "factor", "logical"), selected = sapply(cars_df, class)))),
usage = sapply(selectInputIDb, function(x)as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = "sel")))
)
ui <- fluidPage(
DT::dataTableOutput(outputId = 'my_table'),
br(),
verbatimTextOutput("table")
)
server <- function(input, output, session)
displayTbl <- reactive(
dplyr::tibble(
variables = names(cars_df),
data_class = sapply(selectInputIDa, function(x)as.character(selectInput(inputId = x, label = "", choices = c("numeric", "character", "factor", "logical"), selected = input[[x]]))),
usage = sapply(selectInputIDb, function(x)as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = input[[x]])))
)
)
output$my_table = DT::renderDataTable(
DT::datatable(
initMeta, escape = FALSE, selection = 'none', rownames = FALSE,
options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
preDrawCallback = JS('function() Shiny.unbindAll(this.api().table().node()); '),
drawCallback = JS('function() Shiny.bindAll(this.api().table().node()); ')
)
)
, server = TRUE)
my_table_proxy <- dataTableProxy(outputId = "my_table", session = session)
observeEvent(sapply(selectInputIDa, function(x)input[[x]]),
replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
, ignoreInit = TRUE)
observeEvent(sapply(selectInputIDb, function(x)input[[x]]),
replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
, ignoreInit = TRUE)
output$table <- renderPrint(displayTbl())
shinyApp(ui = ui, server = server)
【问题讨论】：
您写道，这不起作用。但是，问题是否有可能是特定功能不起作用？我有 DT .19，我使用您提供的 URL 访问了代码的来源。我看到了桌子；我可以编辑和突出显示行。下载作品。我错过了什么？ Kat，感谢您花时间看这个。我添加了更多关于我看到的行为的上下文，随后使用我也包含在内的 reactlog 进行了一些比较。 你有没有想过跳过JS？ Check out these examples. 还有这个related post。 @ismirsehregal 这正是我想要做的。显然，我没有足够的精力来解决最后一步。这是一个优雅的解决方案。谢谢。 【参考方案1】：要获取resultTbl，您只需访问input[x]：
library(DT)
library(shiny)
library(dplyr)
cars_df <- mtcars
selectInputIDa <- paste0("sela", 1:length(cars_df))
selectInputIDb <- paste0("selb", 1:length(cars_df))
initMeta <- dplyr::tibble(
variables = names(cars_df),
data_class = sapply(selectInputIDa, function(x)as.character(selectInput(inputId = x, label = "", choices = c("character","numeric", "factor", "logical"), selected = sapply(cars_df, class)))),
usage = sapply(selectInputIDb, function(x)as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = "sel")))
)
ui <- fluidPage(
DT::dataTableOutput(outputId = 'my_table'),
br(),
verbatimTextOutput("table")
)
server <- function(input, output, session)
displayTbl <- reactive(
dplyr::tibble(
variables = names(cars_df),
data_class = sapply(selectInputIDa, function(x)as.character(selectInput(inputId = x, label = "", choices = c("numeric", "character", "factor", "logical"), selected = input[[x]]))),
usage = sapply(selectInputIDb, function(x)as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = input[[x]])))
)
)
resultTbl <- reactive(
dplyr::tibble(
variables = names(cars_df),
data_class = sapply(selectInputIDa, function(x)input[[x]]),
usage = sapply(selectInputIDb, function(x)input[[x]])
)
)
output$my_table = DT::renderDataTable(
DT::datatable(
initMeta, escape = FALSE, selection = 'none', rownames = FALSE,
options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
preDrawCallback = JS('function() Shiny.unbindAll(this.api().table().node()); '),
drawCallback = JS('function() Shiny.bindAll(this.api().table().node()); ')
)
)
, server = TRUE)
my_table_proxy <- dataTableProxy(outputId = "my_table", session = session)
observeEvent(sapply(selectInputIDa, function(x)input[[x]]),
replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
, ignoreInit = TRUE)
observeEvent(sapply(selectInputIDb, function(x)input[[x]]),
replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
, ignoreInit = TRUE)
output$table <- renderPrint(resultTbl())
shinyApp(ui = ui, server = server)
【讨论】：
以上是关于使用下拉选择编辑闪亮的数据表（对于 DT v0.19）的主要内容，如果未能解决你的问题，请参考以下文章
为 DT 闪亮中的单列渲染下拉列表，但仅在单元格单击时加载并使用 replaceData()
DT::datatable - 选择要删除的行并写入没有闪亮的 csv
在闪亮应用程序的 DT::datatable 中添加、删除和编辑行