Updating DataTable using DropDown Within DataTable - r

Question

I am trying to update a sample DataTable dynamically using dropdowns that I created within the DataTable. However, it doesn't seem to update regardless of what I try. The sample code below is what I am currently working with in order to update the Species column when the input is selected from the species_selector column.
library(shiny)
library(DT)
ui <- fluidPage(
title = 'Selectinput column in a table',
h3("Source:", tags$a("Yihui Xie", href = "https://yihui.shinyapps.io/DT-radio/")),
DT::dataTableOutput('foo'),
actionButton(inputId = "submit", label = "Submit"),
verbatimTextOutput('sel')
)
server <- function(input, output, session) {
data <- head(iris, 5)
for (i in 1:nrow(data)) {
data$species_selector[i] <- as.character(selectInput(paste0("sel", i), "", choices = unique(iris$Species), width = "100px"))
}
output$foo = DT::renderDataTable(
data, escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-container');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
observeEvent(input$submit, {
update_data <- reactive({
df <- data
for(i in 1:nrow(df)) {
df$Species[i] <- as.character(input[[paste0("sel", i)]])
}
return(df)
})
data <- update_data()
})
output$sel = renderPrint({
for(i in 1:nrow(data)) {
data$Species[i] <- as.character(input[[paste0("sel", i)]])
}
data
})
}
shinyApp(ui, server)
Any help would be appreciated. Thank you!

Answer 1

Is it something like this you want?
library(shiny)
library(DT)
selector <- function(id, values, items = values){
options <- HTML(paste0(mapply(
function(i, item){
value <- values[i]
if(i == 1L){
opt <- tags$option(value = value, selected = "selected", item)
}else{
opt <- tags$option(value = value, item)
}
as.character(opt)
}, seq_along(values), items
), collapse = ""))
as.character(tags$select(id = id, options))
}
js <- c(
"function(settings) {",
" var table = this.api().table();",
" var $tbl = $(table.table().node());",
" var id = $tbl.closest('.datatables').attr('id');",
" var nrows = table.rows().count();",
" function selectize(i) {",
" var $slct = $('#slct' + i);",
" $slct.select2({",
" width: '100%',",
" closeOnSelect: true",
" });",
" $slct.on('change', function(e) {",
" var info = [{",
" row: i,",
" col: 4,",
" value: $slct.val()",
" }];",
" Shiny.setInputValue(id + '_cell_selection:DT.cellInfo', info);",
" });",
" }",
" for(var i = 1; i <= nrows; i++) {",
" selectize(i);",
" }",
"}"
)
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js")
),
br(),
DTOutput("dtable"),
tags$hr(),
h2("Edited table:"),
tableOutput("table")
)
server <- function(input, output, session) {
dat <- head(iris, 3L)
Dat <- reactiveVal(dat)
for(i in 1L:nrow(dat)){
dat$species_selector[i] <-
selector(id = paste0("slct", i), values = unique(iris$Species))
}
output[["dtable"]] <- renderDT({
datatable(
data = dat,
selection = "none",
escape = FALSE,
rownames = FALSE,
options = list(
initComplete = JS(js),
preDrawCallback = JS(
"function() { Shiny.unbindAll(this.api().table().node()); }"
),
drawCallback = JS(
"function() { Shiny.bindAll(this.api().table().node()); }"
)
)
)
}, server = TRUE)
observeEvent(input[["dtable_cell_selection"]], {
info <- input[["dtable_cell_selection"]]
Dat(editData(Dat(), info, rownames = FALSE))
})
output[["table"]] <- renderTable({
Dat()
})
}
shinyApp(ui, server)

Answer 2

You can take help of reactive values to save the dataframe and perform the changes in the same.
library(shiny)
library(DT)
data <- head(iris, 5)
for (i in 1:nrow(data)) {
data$species_selector[i] <- as.character(selectInput(paste0("sel", i), "", choices = unique(iris$Species), width = "100px"))
}
ui <- fluidPage(
title = 'Selectinput column in a table',
h3("Source:", tags$a("Yihui Xie", href = "https://yihui.shinyapps.io/DT-radio/")),
DT::dataTableOutput('foo'),
actionButton(inputId = "submit", label = "Submit"),
verbatimTextOutput('sel')
)
server <- function(input, output, session) {
rv <- reactiveValues(data = data)
output$foo = DT::renderDataTable(
rv$data, escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-container');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
observeEvent(input$submit, {
for(i in 1:nrow(rv$data)) {
rv$data$Species[i] <- as.character(input[[paste0("sel", i)]])
}
})
}
shinyApp(ui, server)