Shiny: keep boxes checked on datatable after changing inputs - r

Question

I want to implement checkboxes into my shiny app; however, I'm facing two problems:
After I reorder columns, any checks on the datatable disappear (e.g., try to order table by mpg)
After I remove column, any checks on the datatable disappear (e.g., unchecking boxes from Columns to show:)
Here's my dummy example (it's a modified version of code from this SO answer):
library(shiny)
TABLE = mtcars
TABLE$id = 1:nrow(mtcars)
APP <- list()
APP$ui <- pageWithSidebar(
headerPanel(NULL),
sidebarPanel(
checkboxGroupInput("show_vars", "Columns to show:",
names(TABLE), selected = names(TABLE))
),
mainPanel(
dataTableOutput("resultTABLE")
)
)
APP$server <- function(input, output, session) {
output$resultTABLE = renderDataTable({
addCheckboxButtons <- paste0('<input type="checkbox" name="row',
TABLE$id, '" value="', TABLE$id, '">',"")
cbind(Pick = addCheckboxButtons, TABLE[, input$show_vars, drop = FALSE])
}, escape = FALSE)
}
runApp(APP)
APP works, but for the full implementation I need to solve problems 1 and 2.

Answer 1

Based on the SO answer provided in your question:
library(shiny)
mymtcars = mtcars
mymtcars$id = 1:nrow(mtcars)
runApp(
list(ui = pageWithSidebar(
headerPanel('Examples of DataTables'),
sidebarPanel(
checkboxGroupInput('show_vars', 'Columns to show:', names(mymtcars),
selected = names(mymtcars))
),
mainPanel(
dataTableOutput("mytable")
)
)
, server = function(input, output, session) {
strd<-reactiveValues(tr=0, slrows=character(length=nrow(mymtcars)))
#preserve selected rows in a reactive element
rowSelect <- reactive({
input$rows
})
# use reactive value that's equal to 'checked' parameter for html code
observe({
strd$slrows<-ifelse(mymtcars$id %in% as.numeric(rowSelect()),'checked','' )
})
#use observer for column checkboxinput to detect first run
observeEvent(input$show_vars, {
strd$tr<-strd$tr+1
print(strd$tr)
}, ignoreNULL = TRUE)
output$mytable = renderDataTable({
#if first run - nothing is checked
if (strd$tr==1){
addCheckboxButtons <- paste0('<input type="checkbox" name="row', mymtcars$id, '" value="', mymtcars$id, '" >',"")
} else{
# add 'checked' parameter for html depending if id is present in selected rows reactive value
addCheckboxButtons <- paste0('<input type="checkbox" name="row', mymtcars$id, '" value="', mymtcars$id,'" ',
strd$slrows,'>',"")
}
#Display table with checkbox buttons
(cbind(Pick=addCheckboxButtons, mymtcars[, input$show_vars, drop=FALSE]))
}, options = list(orderClasses = TRUE, lengthMenu = c(5, 25, 50), pageLength = 25),
escape=FALSE, callback = "function(table) {
table.on('change.dt', 'tr td input:checkbox', function() {
setTimeout(function () {
Shiny.onInputChange('rows', $(this).add('tr td input:checkbox:checked').parent().siblings(':last-child').map(function() {
return $(this).text();
}).get())
}, 10);
});
}")
}
)
)
Similar, but DT approach: (a bit more efficient as you don't create input for each row and as a consequence it won't recreate table for each reactive values trigger (that's is columns and rows ticks). It recreates table only in column reactive value trigger. You can also use colvis in buttons extension in order to get along with pure DT solution
library(shiny)
library(DT)
mymtcars<-mtcars
shinyApp(
ui = pageWithSidebar(
headerPanel('Examples of DataTables'),
sidebarPanel(
checkboxGroupInput('show_vars', 'Columns to show:', names(mymtcars),
selected = names(mymtcars))
),
mainPanel(
verbatimTextOutput("selrows"),
DT::dataTableOutput("mytable")
)
),
server = function(input, output) {
strd<-reactiveValues(tr=0, slrows=c(0,0))
observe({
if(strd$tr==1){
strd$slrows<-0
} else strd$slrows<-input$mytable_rows_selected
})
rowSelect <- reactive({
input$mytable_rows_selected
})
observeEvent(input$show_vars, {
strd$tr<-strd$tr+1
print(strd$tr)
}, ignoreNULL = TRUE)
output$mytable = DT::renderDataTable({
datatable(mymtcars[, input$show_vars, drop=F], rownames=FALSE,options = list(pageLength = 10),
selection = list(mode='multiple', target='row',
selected = strd$slrows) )
}
)
output$selrows<-renderPrint({
input$mytable_rows_selected
})
}
)