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 = 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);
});
}")
}
)
)
R Shiny picking and storing favorites from checked dataTables
Ok, so this is a working solution now - for anyone else interested.
It will read the value of the checkbox, and send it to the favorites table on click.
app.R
mymtcars1 = mtcars
mymtcars2 = mtcars
mymtcars3 = mtcars
mymtcars1$id = 1:nrow(mtcars)
mymtcars2$id = 1:nrow(mtcars)
mymtcars3$id = 1:nrow(mtcars)
server <- function(input, output, session) {
rowSelect1 <- reactive({
if(!is.null(input[["rows1"]])) paste(sort(unique(input[["rows1"]])),sep=',')
})
rowSelect2 <- reactive({
if(!is.null(input[["rows2"]])) paste(sort(unique(input[["rows2"]])),sep=',')
})
rowSelect3 <- reactive({
if(!is.null(input[["rows3"]])) paste(sort(unique(input[["rows3"]])),sep=',')
})
output$favorites_table1 <- renderText(rowSelect1())
output$favorites_table2 <- renderText(rowSelect2())
output$favorites_table3 <- renderText(rowSelect3())
output$mytable1 = renderDataTable({
mymtcars <- mymtcars1
addCheckboxButtons <- paste0('<input id="table1" type="checkbox" name="row', mymtcars$id, '" value="op', mymtcars$id, '">',"")
#Display table with checkbox buttons
cbind(Pick=addCheckboxButtons, mymtcars)
}, options = list(orderClasses = TRUE, lengthMenu = c(5, 25, 50), pageLength = 25),
escape = FALSE,
callback = "function(table) {
table.on('change.dt', '#table1:checkbox', function() {
setTimeout(function () {
Shiny.onInputChange('rows1', $('#table1:checked').map(function() {
return $(this).val();
}).get())
}, 10);
});
}")
output$mytable2 = renderDataTable({
mymtcars <- mymtcars2
addCheckboxButtons <- paste0('<input id="table2" type="checkbox" name="row', mymtcars$id, '" value="val', mymtcars$id, '">',"")
#Display table with checkbox buttons
cbind(Pick=addCheckboxButtons, mymtcars)
}, options = list(orderClasses = TRUE, lengthMenu = c(5, 25, 50), pageLength = 25),
escape = FALSE,
callback = "function(table) {
table.on('change.dt', '#table2:checkbox', function() {
setTimeout(function () {
Shiny.onInputChange('rows2', $('#table2:checked').map(function() {
return $(this).val();
}).get())
}, 10);
});
}")
output$mytable3 = renderDataTable({
mymtcars <- mymtcars3
addCheckboxButtons <- paste0('<input id="table3" type="checkbox" name="row', mymtcars$id, '" value="', mymtcars$id, '">',"")
#Display table with checkbox buttons
cbind(Pick=addCheckboxButtons, mymtcars[,-ncol(mymtcars)])
}, options = list(orderClasses = TRUE, lengthMenu = c(5, 25, 50), pageLength = 25),
escape = FALSE,
callback = "function(table) {
table.on('change.dt', '#table3:checkbox', function() {
setTimeout(function () {
Shiny.onInputChange('rows3', $('#table3:checked').map(function() {
return $(this).val();
}).get())
}, 10);
});
}")
store_favorites <- function(rds="favorites.Rds", inputidx, name){
if(file.exists(rds)) favorites <- readRDS(rds) else favorites <- data.frame("Table"=character(0), "Key"=character(0))
if(length(input[[inputidx]])>0) {
new_favorites <- unique(rbind(favorites, data.frame("Table"=name,"Key"=input[[inputidx]])))
saveRDS(new_favorites, rds)
new_favorites
} else {
favorites
}
}
favorites1 <- reactive({
input$send_table1
isolate({store_favorites(inputidx="rows1", name="Table1")})
})
favorites2 <- reactive({
input$send_table2
isolate({store_favorites(inputidx="rows2", name="Table2")})
})
favorites3 <- reactive({
input$send_table3
isolate({store_favorites(inputidx="rows3", name="Table3")})
})
output$favorites_table <- renderDataTable({
# Re-evaluate favorites each time one of the buttons are pressed
input$send_table1
input$send_table2
input$send_table3
isolate({
#Unneccessary to bind the same table 3 times, then unique - but this works
all_favs <- unique(rbind(favorites1(),favorites2(),favorites3()))
})
validate(
need(nrow(all_favs)>0, paste0("No favorites stored"))
)
all_favs
})
}
ui <- shinyUI(
pageWithSidebar(
headerPanel('Examples of DataTables'),
sidebarPanel(
inputPanel(
h5("Selected (table 1)"),br(),
verbatimTextOutput("favorites_table1"),
actionButton(inputId = "send_table1", "Save 1", class="btn-mini")
),
inputPanel(
h5("Selected (table 2)"),br(),
verbatimTextOutput("favorites_table2"),
actionButton(inputId = "send_table2", "Save 2", class="btn-mini")
),
inputPanel(
h5("Selected (table 3)"),br(),
verbatimTextOutput("favorites_table3"),
actionButton(inputId = "send_table3", "Save 3", class="btn-mini")
)
),
mainPanel(
tabsetPanel(
tabPanel("Table1",
dataTableOutput("mytable1")
),
tabPanel("Table2",
dataTableOutput("mytable2")
),
tabPanel("Table3",
dataTableOutput("mytable3")
),
tabPanel("Favorites",
dataTableOutput("favorites_table")
)
)
)
)
)
shinyApp(ui = ui, server = server)
R Shiny : Get data from selected row
Here is a complete example based on the Shiny example you referenced. This uses mpg data from ggplot2.
First, you can create a reactive expression to determine which rows should be filtered and shown in the table. Whenever one of your inputs change, then the reactive expression will be reevaluated. To access the filtered data, you can reference as filtered_rows() (note the parentheses).
To get the selected rows, you can use input$table_rows_selected since your dataTableOutput is called table (just append "_rows_selected"). This can be one or more than one rows, and returns row numbers (e.g., 8 in your example above). Then, to extract your data, you can use filtered_rows()[input$table_rows_selected, c("model", "trans")] which will include model and trans column data for the filtered rows.
The verbatimTextOutput and toString simply show the results for validation and demonstration. You can use the results in another context as well.
library(shiny)
library(DT)
library(ggplot2)
ui <- fluidPage(
titlePanel("Basic DataTable"),
# Create a new Row in the UI for selectInputs
fluidRow(
column(4,
selectInput("man",
"Manufacturer:",
c("All",
unique(as.character(mpg$manufacturer))))
),
column(4,
selectInput("trans",
"Transmission:",
c("All",
unique(as.character(mpg$trans))))
),
column(4,
selectInput("cyl",
"Cylinders:",
c("All",
unique(as.character(mpg$cyl))))
)
),
# Create a new row for the table.
DT::dataTableOutput("table"),
verbatimTextOutput("text")
)
server <- function(input, output) {
# Filter data based on selections
filtered_rows <- reactive({
data <- mpg
if (input$man != "All") {
data <- data[data$manufacturer == input$man,]
}
if (input$cyl != "All") {
data <- data[data$cyl == input$cyl,]
}
if (input$trans != "All") {
data <- data[data$trans == input$trans,]
}
data
})
# Show filtered data in the datatable
output$table <- DT::renderDataTable(DT::datatable({ filtered_rows() }))
# Show selected text
output$text <- renderText({ toString(filtered_rows()[input$table_rows_selected, c("model", "trans")]) })
}
shinyApp(ui, server)
R Shiny - Pre-selection of rows in Select extension for Datatables
There's no select.rows option. You can use a callback:
output[["table"]] <- renderDT({
datatable(
dat,
callback = JS("table.rows([0,1,2]).select();"),
options = list(select = list(
style = "multi",
selector = "td:not(.notselectable)")),
extensions = "Select", selection = "none")
}, server = FALSE)
R shiny datatables don't show records (rows) at start
You could make your own search functionality:
EDIT: added second character column that is being searched.
shinyApp(
ui = navbarPage(
title = 'DataTable',
textInput('search', 'search'),
DT::dataTableOutput('ex2')
),
server = function(input, output, session) {
require(dplyr)
iris.mut <- iris %>%
mutate(bottom = paste0('v',sapply(Sepal.Width,function(x)paste0(rep('z',x*2),collapse="")),'bx'))
dat <- reactive({
if(input$search!=''){
iris.mut %>%
filter(grepl(input$search,Species)|grepl(input$search,bottom))
} else {
iris.mut %>%
filter(Species == input$search)
}
})
output$ex2 <- DT::renderDataTable(
DT::datatable(
dat(),
options = list(
lengthMenu = list(c(5, 15, -1), c('5', '15', 'All'))
)
))
}
)
Shiny: keep boxes checked on datatable after changing inputs
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
})
}
)
Shiny DT appearance messed up when selected rows used as reactive values
The issue is caused by the part style = 'bootstrap' which does not work well with return(NULL). Replacing if (rv$val == FALSE) return() with req(rv$val) in the output has solved the problem. Has taken the reference here.
Related Topics
Convert Data Frame with Date Column to Timeseries
How to Set the Default Language of Date in R
Is There a _Fast_ Way to Run a Rolling Regression Inside Data.Table
Replace Empty Values with Value from Other Column in a Dataframe
Reasons That Ggplot2 Legend Does Not Appear
Converting a Character String into a Date in R
How Can a Data Ellipse Be Superimposed on a Ggplot2 Scatterplot
Using R Statistics Add a Group Sum to Each Row
Non-Redundant Version of Expand.Grid
How to 'Print' or 'Cat' When Using Parallel
How to Return Number of Decimal Places in R
Plot.New Has Not Been Called Yet
Plot a Line Chart with Conditional Colors Depending on Values
Set Ggplot Plots to Have Same X-Axis Width and Same Space Between Dot Plot Rows