Add dropdown list to every column in a DT table where the values from the dropdown lists are fetched from another dataframe
This seems to work:
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)
EDIT
The previous callback changes the value of the cell only on the display of the table, it does not change the data of the table. It is better to use the following callback:
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();",
" }",
" }",
" };",
" }",
"});"
)