使用因子变量的下拉选择来编辑Shiny中的数据表 [英] Edit datatable in Shiny with dropdown selection for factor variables
问题描述
我正在尝试创建一个Shiny应用程序，该应用程序允许用户编辑数据表，从而保存编辑内容。这是一个最小的示例：
I am trying to create a Shiny app that allows users to edit a datatable, whereby the edits are saved. Here is a minimal example:
library(shiny)
library(DT)
ui <- fluidPage(
DT::DTOutput('df')
)
server <- function(session, input, output){
df <- data.frame(x = factor(c("A", "B", "C"), levels = c("A", "B", "C")))
output$df <- DT::renderDT(df,
editable = T)
proxy <- dataTableProxy("df")
observeEvent(input$df_cell_edit, {
info <- input$df_cell_edit
str(info)
i <- info$row
j <- info$col
v <- info$value
df[i, j] <<- DT:::coerceValue(v, df[i, j])
replaceData(proxy, df, resetPaging = FALSE)
})
}
shinyApp(ui, server)
这使我可以在线编辑 x 的值，但是由于 x 是一个因素，我希望限制用户能够输入的值。理想情况下，我希望使用下拉菜单来完成此操作。可以使用DT :: datatable和Shiny吗？
This allows me to edit the values of x in-line, but since x is a factor, I'd like to restrict the values that the user is able to input. Ideally, I would like this to be accomplished using a drop-down menu. Is this functionality possible using DT::datatable and Shiny?
注意：我知道 rhandsontable 包，但是我更愿意使用DT。
Note: I know of the rhandsontable package, however I would prefer to use DT if possible.
推荐答案
正如我在评论中说的那样，您可以
As I said in a comment, you can do that with the JS library cellEdit.
这是使用JS库 contextMenu （jQuery插件）的另一种方法。 / p>
Here is another way, using the JS library contextMenu (a jQuery plugin).
library(shiny)
library(DT)
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 colindex = table.cell($trigger.parent()[0]).index().column;",
" var coldata = table.column(colindex).data().unique();",
" var options = coldata.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');",
" }",
" }",
" };",
" }",
"});"
)
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("dtable")
)
server <- function(input, output){
output[["dtable"]] <- renderDT({
datatable(
iris, editable = "cell", callback = JS(callback),
options = list(
columnDefs = list(
list(
targets = 5, className = "factor"
)
)
)
)
}, server = FALSE)
}
shinyApp(ui, server)
这是一个改进。在上一个应用程序中，下拉选项设置为该列的唯一值。在下面的应用中，您可以设置所需的下拉选项。
Here is an improvement. In the previous app, the dropdown options are set to the unique values of the column. With the app below, you can set the dropdown options you want.
library(shiny)
library(DT)
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("dtable")
)
server <- function(input, output){
output[["dtable"]] <- renderDT({
datatable(
iris, editable = "cell", callback = JS(callback),
options = list(
columnDefs = list(
list(
targets = 5,
className = "factor",
createdCell = JS(createdCell(c(levels(iris$Species), "another level")))
)
)
)
)
}, server = FALSE)
}
shinyApp(ui, server)
如果要使用列的唯一值，请设置选项 createdCell 到 JS（createdCell（）），或者干脆不设置此选项。
If you want to use the unique values of the column, set the option createdCell to JS(createdCell()), or simply don't set this option.
这篇关于使用因子变量的下拉选择来编辑Shiny中的数据表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
