我根据Stephane Laurent对以下堆栈溢出问题的解决方案编写了以下代码：
在Shiny中编辑数据表，下拉选择因子变量
我添加了使用editData更新表并能够保存/导出更新的代码。
以下内容适用于DT v0.18，但对于DT v0.19，我发现id_cell_edit似乎没有触发。我不确定这是否与回调有关，或者可能与jquery.contextMenu有关，因为DT v0.19升级到了jquery3.0。如果人们对如何解决这一问题有任何见解，我将不胜感激。
以下是我在使用v0.18时观察到的行为的描述。当我选择usage列并将第一行的值从默认的"sel"更新为"id"时，DT表中的值会发生变化。我还看到它更新了tibble的视图，因此下载csv文件中的数据也更新了。如果我进入下一页查看第11项，然后返回到第一页，我可以看到我更新的记录仍然显示"id"。
以下是我在使用v0.19时观察到的行为的描述。当我选择usage列并将第一行的值从默认的"sel"更新为"id"时，DT表中的值会发生变化。它不会更新tibble的视图，因此下载csv文件中的数据不会更新。如果我进入下一页查看第11项，然后返回到第一页，我所做的更新将被清除。
请注意，我还使用reactlog运行了反应图。我按照相同的步骤将第一行的用法列更新为"；id"；。我注意到的第一个区别是，当我使用v0.18版本时，步骤5中的reactiveValues###$dt给了我一个7的列表，而当我使用版本v0.19时，它给了我8的列表。在步骤16，对于v0.18，输入$dt_cell_edit无效，然后Data无效，输出$table无效。然而，在步骤16中，当使用v0.19时，输出$dt无效，然后输出$table无效。换句话说，当使用v0.19时，输入$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的解决方案应用到我的用例中。我还在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)
要获得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)
附言：这是基于我之前的回答。
PPS：在这里可以找到后续帖子。