RStudio Shiny list from checking rows in dataTables - r

Question

I would like to have a working example similar to this:
https://demo.shinyapps.io/029-row-selection/
I tried the example in my Shiny server running Shiny Server v1.1.0.10000, packageVersion: 0.10.0 and Node.js v0.10.21, but it is not working even if I load the js and css files from the website. It simply does not select rows from the table:
# ui.R
library(shiny)
shinyUI(fluidPage(
title = 'Row selection in DataTables',
tagList(
singleton(tags$head(tags$script(src='//cdn.datatables.net/1.10.2/js/jquery.dataTables.js',type='text/javascript'))),
singleton(tags$head(tags$script(src='//cdn.datatables.net/1.10.2/css/jquery.dataTables.min.css',type='text/css')))
),
sidebarLayout(
sidebarPanel(textOutput('rows_out')),
mainPanel(dataTableOutput('tbl')),
position = 'right'
)
))
# server.R
library(shiny)
shinyServer(function(input, output) {
output$tbl <- renderDataTable(
mtcars,
options = list(pageLength = 10),
callback = "function(table) {
table.on('click.dt', 'tr', function() {
$(this).toggleClass('selected');
Shiny.onInputChange('rows',
table.rows('.selected').indexes().toArray());
});
}"
)
output$rows_out <- renderText({
paste(c('You selected these rows on the page:', input$rows),
collapse = ' ')
})
})
I then tried to do this from a different example that was using radio buttons to re-sort the rows.
In my modified example, I want to produce a list of ids from the selected checkbox buttons of the dataTables table shown in the webpage. E.g., selecting some rows from the first 5, I want my textbox to be: 1,3,4 corresponding to the mymtcars$id column I added to mtcars. I then plan to link an action to the values of the textbox.
I have it almost there in this example, but checking the boxes does not update the list in the textbox. Differently to the example shinyapp, I would like my checkboxes to keep the selection status if the table is resorted. This may be the tricky part, and I am not sure how to do it. I would also like to add a "Select/Unselect all" textbox on the top left corner of the table, that selects/unselects all boxes in the table. Any ideas?
# server.R
library(shiny)
mymtcars = mtcars
mymtcars$id = 1:nrow(mtcars)
shinyServer(function(input, output, session) {
rowSelect <- reactive({
if (is.null(input[["row"]])) {
paste(sort(unique(rep(0,nrow(mymtcars)))),sep=',')
} else {
paste(sort(unique(input[["row"]])),sep=',')
}
})
observe({
updateTextInput(session, "collection_txt",
value = rowSelect()
,label = "Foo:"
)
})
# sorted columns are colored now because CSS are attached to them
output$mytable = renderDataTable({
addCheckboxButtons <- paste0('<input type="checkbox" name="row', mymtcars$id, '" value="', mymtcars$id, '">',"")
#Display table with checkbox buttons
cbind(Pick=addCheckboxButtons, mymtcars[, input$show_vars, drop=FALSE])
}, options = list(bSortClasses = TRUE, aLengthMenu = c(5, 25, 50), iDisplayLength = 25))
})
# ui.R
library(shiny)
mymtcars = mtcars
mymtcars$id = 1:nrow(mtcars)
shinyUI(pageWithSidebar(
headerPanel('Examples of DataTables'),
sidebarPanel(
checkboxGroupInput('show_vars', 'Columns to show:', names(mymtcars),
selected = names(mymtcars))
),
mainPanel(
dataTableOutput("mytable")
,textInput("collection_txt",label="Foo")
)
)
)

Answer 1

For the first problem you need the dev version of shiny and htmltools >= 0.2.6 installed:
# devtools::install_github("rstudio/htmltools")
# devtools::install_github("rstudio/shiny")
library(shiny)
runApp(list(ui = fluidPage(
title = 'Row selection in DataTables',
sidebarLayout(
sidebarPanel(textOutput('rows_out')),
mainPanel(dataTableOutput('tbl')),
position = 'right'
)
)
, server = function(input, output) {
output$tbl <- renderDataTable(
mtcars,
options = list(pageLength = 10),
callback = "function(table) {
table.on('click.dt', 'tr', function() {
$(this).toggleClass('selected');
Shiny.onInputChange('rows',
table.rows('.selected').indexes().toArray());
});
}"
)
output$rows_out <- renderText({
paste(c('You selected these rows on the page:', input$rows),
collapse = ' ')
})
}
)
)
for your second example:
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))
,textInput("collection_txt",label="Foo")
),
mainPanel(
dataTableOutput("mytable")
)
)
, server = function(input, output, session) {
rowSelect <- reactive({
paste(sort(unique(input[["rows"]])),sep=',')
})
observe({
updateTextInput(session, "collection_txt", value = rowSelect() ,label = "Foo:" )
})
output$mytable = renderDataTable({
addCheckboxButtons <- paste0('<input type="checkbox" name="row', mymtcars$id, '" value="', mymtcars$id, '">',"")
#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)
, 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);
});
}")
}
)
)

Answer 2

This answer has been rendered broken in shiny 0.11.1, but can easily be fixed. Here is the update that did it (link):
Added an escape argument to renderDataTable() to escape the HTML entities
in the data table for security reasons. This might break tables from previous
versions of shiny that use raw HTML in the table content, and the old behavior
can be brought back by escape = FALSE if you are aware of the security
implications. (#627)
Thus, to make the previous solutions work, one must specify escape = FALSE as an option to renderDataTable().

Answer 3

I have made an alternative for check boxes in tables based on the previous Answer code and some tweaking of the JQuery / JavaScript.
For anyone who prefers actual data over row numbers i wrote this code that extracts data from the table and shows that as selection. You can deselect by clicking again. It builds on the former Answers that were very helpful to me (THANKS) so i want to share this as well.
It needs a session object to keep the vector alive (scoping). Actually you can get whatever information you want from the table, just dive into JQuery and change the $row.find('td:nth-child(2)') (number is the column number).I needed the info from the Second column but it is up to you. Selection colors is a bit odd if you also change the visible column amount.... selection colors tend to disappear...
I hope this is helpful, works for me (needs to be optimized but no time for that now)
output$tbl <- renderDataTable(
mtcars,
options = list(pageLength = 6),
callback = "function(table) {
table.on('click.dt', 'tr', function() {
if ( $(this).hasClass('selected') ) {
$(this).removeClass('selected');
} else {
table.$('tr.selected').removeClass('selected');
$(this).addClass('selected');
}
var $row = $(this).closest('tr'),
$tdsROW = $row.find('td'),
$tdsUSER = $row.find('td:nth-child(2)');
$.each($tdsROW, function() {
console.log($(this).text());
});
Shiny.onInputChange('rows',table.rows('.selected').indexes().toArray());
Shiny.onInputChange('CELLselected',$tdsUSER.text());
Shiny.onInputChange('ROWselected',$(this).text());
});
}"
)
output$rows_out <- renderUI({
infoROW <- input$rows
if(length(input$CELLselected)>0){
if(input$CELLselected %in% session$SelectedCell){
session$SelectedCell <- session$SelectedCell[session$SelectedCell != input$CELLselected]
}else{
session$SelectedCell <- append(session$SelectedCell,input$CELLselected)
}
}
htmlTXT <- ""
if(length(session$SelectedCell)>0){
for(i in 1:length(session$SelectedCell)){
htmlTXT <- paste(htmlTXT,session$SelectedCell[i],sep="<br/>")
}
}else{htmlTXT <- "please select from the table"}
HTML(htmlTXT)
})

Answer 4

The answers above are outdated. I received error "Error in datatable: The 'callback' argument only accept a value returned from JS()".
Instead, This one works for me.