基于发现的非常有用的生殖示例 here ，我在 DT 表的每一列中添加了一个下拉列表。
但是，我正在寻找一种方法，使用另一个数据帧中的值填充这些下拉列表，该数据帧与 DT 表中使用的列名称相同。
我尝试使用输入$dtable_columns_selected对第二个数据帧(此处为“iris2”)进行子集化，但我认为我在这里遗漏了一些东西......
我的尝试:
library(shiny)
library(DT)
Sepal.Length <- c(10,11,12,13,14)
Sepal.Width <- c(1,2,3,4,5)
Petal.Length <- c(10,11,12,13,14)
Petal.Width <- c(1,2,3,4,5)
Species <- c("SpeciesA", "SpeciesB","SpeciesC", "SpeciesD", "SpeciesE")
iris2 <- data.frame(Sepal.Length, Sepal.Width,Petal.Length,Petal.Width)
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 = "_all",
className = "factor",
createdCell = JS(createdCell(c(levels(iris2[,input$dtable_columns_selected]))))
)
)
)
)
}, server = FALSE)
}
shinyApp(ui, server)
最佳答案
这似乎有效:
library(shiny)
library(DT)
library(jsonlite)
Sepal.Length <- c(10,11,12,13,14)
Sepal.Width <- c(1,2,3,4,5)
Petal.Length <- c(10,11,12,13,14)
Petal.Width <- c(1,2,3,4,5)
Species <- c("SpeciesA", "SpeciesB", "SpeciesC", "SpeciesD", "SpeciesE")
iris2 <- data.frame(
Sepal.Length,
Sepal.Width,
Petal.Length,
Petal.Width,
Species
)
callback <- c(
"var id = $(table.table().node()).closest('.datatables').attr('id');",
"$.contextMenu({",
" selector: '#' + id + ' td 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.parent().html($input.val());",
" }",
" }",
" };",
" }",
"});"
)
createdCell <- function(dat2){
dat2_json <- toJSON(dat2, dataframe = "values")
c(
"function(td, cellData, rowData, rowIndex, colIndex){",
sprintf(" var matrix = %s;", dat2_json),
" var tmatrix = matrix[0].map((col, i) => matrix.map(row => row[i]));", # we transpose
" $(td).attr('data-levels', JSON.stringify(tmatrix[colIndex]));",
"}"
)
}
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 = list(target = "cell", numeric = "none"),
callback = JS(callback), rownames = FALSE,
options = list(
columnDefs = list(
list(
targets = "_all",
createdCell = JS(createdCell(iris2))
)
)
)
)
}, server = FALSE)
}
shinyApp(ui, server)
编辑
前面的回调仅在表格显示时更改单元格的值，它不会更改表格的数据。最好使用以下回调:
callback <- c(
"var id = $(table.table().node()).closest('.datatables').attr('id');",
"$.contextMenu({",
" selector: '#' + id + ' td 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;",
" var td = $input.parent();",
" $input.remove();",
" table.cell(td).data(options[data.dropdown]).draw();",
" }",
" }",
" };",
" }",
"});"
)
关于r - 将下拉列表添加到 DT 表中的每一列，其中下拉列表中的值是从另一个数据帧获取的，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/70769455/