使用下拉选择以闪亮方式编辑数据表（适用于 DT v0.19）
Edit datatable in shiny with dropdown selection (for DT v0.19)
我根据 Stephane Laurent 在 Stack Overflow 上对以下问题的解决方案编写了以下代码：
我在代码中添加了使用 editData 来更新 table 并能够 save/export 更新。
以下适用于 DT v0.18 但对于 DT v0.19 我发现 id_cell_edit 似乎没有触发。我不确定它是否与回调或可能 jquery.contextMenu 给定的 DT v0.19 升级到 jquery 3.0 有关。非常感谢人们对如何解决这个问题有任何见解。
这是我在使用 v0.18 时观察到的行为的描述。当我 select 用法列并将第一行的值从默认的“sel”更新为“id”时，DT table 中的值发生变化。我还看到它更新了 tibble 的视图，因此下载的 csv 文件中的数据也更新了。如果我前进到下一页看到第 11 个项目，然后 return 回到第一页，我可以看到我更新的记录仍然显示“id”。
这里描述了我在使用 v0.19 时观察到的行为。当我 select 用法列并将第一行的值从默认的“sel”更新为“id”时，DT table 中的值发生变化。它不会更新 tibble 的视图，因此下载的 csv 文件中的数据不会更新。如果我进入下一页查看第 11 项，然后 return 返回第一页，我所做的更新将被清除。
请注意，我还 运行 使用 reactlog 的反应图。我按照相同的步骤将第一行的用法列更新为“id”。我注意到的第一个区别是，当我使用 v0.18 版本时，第 5 步的 reactiveValues###$dt 给出了一个列表 7，而当我使用 v0.19 版本时，它给出了一个列表 8。在第 16 步，对于 v0.18，input$dt_cell_edit 无效，然后 Data 无效，output$table 无效。然而，在第 16 步使用 v0.19 时，output$dt 无效，然后 output$table 无效。换句话说，当使用 v0.19 时，输入 $dt_cell_edit 和数据不会失效。
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)
下面我将 用于我的用例。我还添加了 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)
我根据 Stephane Laurent 在 Stack Overflow 上对以下问题的解决方案编写了以下代码：
我在代码中添加了使用 editData 来更新 table 并能够 save/export 更新。
以下适用于 DT v0.18 但对于 DT v0.19 我发现 id_cell_edit 似乎没有触发。我不确定它是否与回调或可能 jquery.contextMenu 给定的 DT v0.19 升级到 jquery 3.0 有关。非常感谢人们对如何解决这个问题有任何见解。
这是我在使用 v0.18 时观察到的行为的描述。当我 select 用法列并将第一行的值从默认的“sel”更新为“id”时，DT table 中的值发生变化。我还看到它更新了 tibble 的视图，因此下载的 csv 文件中的数据也更新了。如果我前进到下一页看到第 11 个项目，然后 return 回到第一页，我可以看到我更新的记录仍然显示“id”。
这里描述了我在使用 v0.19 时观察到的行为。当我 select 用法列并将第一行的值从默认的“sel”更新为“id”时，DT table 中的值发生变化。它不会更新 tibble 的视图，因此下载的 csv 文件中的数据不会更新。如果我进入下一页查看第 11 项，然后 return 返回第一页，我所做的更新将被清除。
请注意，我还 运行 使用 reactlog 的反应图。我按照相同的步骤将第一行的用法列更新为“id”。我注意到的第一个区别是，当我使用 v0.18 版本时，第 5 步的 reactiveValues###$dt 给出了一个列表 7，而当我使用 v0.19 版本时，它给出了一个列表 8。在第 16 步，对于 v0.18，input$dt_cell_edit 无效，然后 Data 无效，output$table 无效。然而，在第 16 步使用 v0.19 时，output$dt 无效，然后 output$table 无效。换句话说，当使用 v0.19 时，输入 $dt_cell_edit 和数据不会失效。
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)
下面我将
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)