RStudio Shiny list from checking rows in dataTables
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 = mtcarsmymtcars$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); });}") } ))
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 torenderDataTable()
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 byescape = 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()
.
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)})