Format a vector of rows in italic and red font in R DT (datatable)
Here is a better solution (it took me several hours). This one does not redraw the table when one clicks the button, and it doesn't go wrong when one sorts the table by a column.
library(shiny)
library(DT)
initComplete <- c(
"function(settings) {",
" var table=settings.oInstance.api();",
" $('#SubmitRemoval').on('click', function(){",
" table.$('tr.selected').addClass('x');",
" });",
" $('#UndoRemoval').on('click', function(){",
" table.$('tr').removeClass('x');",
" });",
"}"
)
callback <- "
var xrows = [];
table.on('preDraw', function(e, settings) {
var tbl = settings.oInstance.api();
var nrows = tbl.rows().count();
var rows = tbl.$('tr');
var some = false; var r = 0;
while(!some && r<nrows){
if($(rows[r]).hasClass('x')){
some = true
}
r++;
}
if(some){
xrows = [];
for(var i = 0; i < nrows; i++){
if($(rows[i]).hasClass('x')){
xrows.push(rows[i].getAttribute('id'));
}
}
}
}).on('draw.dt', function(){
for(var i=0; i<xrows.length; i++){
var row = $('#' + xrows[i]);
row.addClass('x');
}
xrows = [];
});
"
ui <- fluidPage(
tags$head(
tags$style(HTML(
".x { background-color: rgb(211,211,211) !important; font-style: italic}
table.dataTable tr.selected.x td { background-color: rgb(211,211,211) !important;}"
))
),
actionButton('SubmitRemoval', 'Exclude selected rows'),
actionButton('UndoRemoval', 'Include full data'),
br(),
DTOutput('mytable')
)
server <- function(input, output,session) {
dat <- cbind(mtcars[1:6,], id=1:6)
output[["mytable"]] <- renderDT({
datatable(dat,
callback = JS(callback),
options = list(
initComplete = JS(initComplete),
rowId = JS(sprintf("function(a){return a[%d];}", ncol(dat))),
columnDefs = list(list(visible=FALSE, targets=ncol(dat)))
)
)
})
proxy <- dataTableProxy("mytable")
observeEvent(input[["UndoRemoval"]], {
proxy %>% selectRows(NULL)
})
}
shinyApp(ui, server)
Update
Here is the version including icons:
library(shiny)
library(DT)
initComplete <- c(
"function(settings) {",
" var table = settings.oInstance.api();",
" var cross = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-remove\"></i></span>'",
" var checkmark = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-ok\"></i></span>'",
" $('#SubmitRemoval').on('click', function(){",
" table.$('tr.selected').addClass('x');",
" table.$('tr.selected')",
" .each(function(){$(this).find('td').eq(1).html(cross);});",
" });",
" $('#UndoRemoval').on('click', function(){",
" table.$('tr').removeClass('x');",
" table.$('tr')",
" .each(function(i){$(this).find('td').eq(1).html(checkmark);});",
" });",
"}"
)
callback <- "
var cross = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-remove\"></i></span>'
var xrows = [];
table.on('preDraw', function(e, settings) {
var tbl = settings.oInstance.api();
var nrows = tbl.rows().count();
var rows = tbl.$('tr');
var some = false; var r = 0;
while(!some && r<nrows){
if($(rows[r]).hasClass('x')){
some = true
}
r++;
}
if(some){
xrows = [];
for(var i = 0; i < nrows; i++){
if($(rows[i]).hasClass('x')){
xrows.push(rows[i].getAttribute('id'));
}
}
}
}).on('draw.dt', function(){
for(var i=0; i<xrows.length; i++){
var row = $('#' + xrows[i]);
row.addClass('x').find('td').eq(1).html(cross);
}
xrows = [];
});
"
ui <- fluidPage(
tags$head(
tags$style(HTML(
".x { background-color: rgb(211,211,211) !important; font-style: italic}
table.dataTable tr.selected.x td { background-color: rgb(211,211,211) !important;}"
))
),
actionButton('SubmitRemoval', 'Exclude selected rows'),
actionButton('UndoRemoval', 'Include full data'),
br(),
DTOutput('mytable')
)
server <- function(input, output,session) {
dat <- cbind(Selected = '<span style="color:red; font-size:18px"><i class="glyphicon glyphicon-ok"></i></span>',
mtcars[1:6,], id = 1:6)
output[["mytable"]] <- renderDT({
datatable(dat,
escape = -2,
callback = JS(callback),
options = list(
initComplete = JS(initComplete),
rowId = JS(sprintf("function(data){return data[%d];}", ncol(dat))),
columnDefs = list(
list(visible = FALSE, targets = ncol(dat)),
list(className = "dt-center", targets = "_all")
)
)
)
})
proxy <- dataTableProxy("mytable")
observeEvent(input[["UndoRemoval"]], {
proxy %>% selectRows(NULL)
})
}
shinyApp(ui, server)
Update
To get the indices of the excluded rows in input$excludedRows:
initComplete <- c(
"function(settings) {",
" var table = settings.oInstance.api();",
" var cross = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-remove\"></i></span>'",
" var checkmark = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-ok\"></i></span>'",
" $('#SubmitRemoval').on('click', function(){",
" table.$('tr.selected').addClass('x');",
" table.$('tr.selected')",
" .each(function(){$(this).find('td').eq(1).html(cross);});",
" var excludedRows = [];",
" table.$('tr').each(function(i, row){",
" if($(this).hasClass('x')){excludedRows.push(parseInt($(row).attr('id')));}",
" });",
" Shiny.setInputValue('excludedRows', excludedRows);",
" });",
" $('#UndoRemoval').on('click', function(){",
" table.$('tr').removeClass('x');",
" table.$('tr')",
" .each(function(i){$(this).find('td').eq(1).html(checkmark);});",
" Shiny.setInputValue('excludedRows', null);",
" });",
"}"
)
Update
This is easier with the option server = FALSE of renderDT:
library(shiny)
library(DT)
initComplete <- c(
"function(settings) {",
" var table = settings.oInstance.api();",
" $('#SubmitRemoval').on('click', function(){",
" table.$('tr.selected').addClass('x').each(function(){",
" var td = $(this).find('td').eq(1)[0];",
" var cell = table.cell(td);",
" cell.data('remove');",
" });",
" table.draw(false);",
" table.rows().deselect();",
" var excludedRows = [];",
" table.$('tr').each(function(i, row){",
" if($(this).hasClass('x')){excludedRows.push(parseInt($(row).attr('id')));}",
" });",
" Shiny.setInputValue('excludedRows', excludedRows);",
" });",
" $('#UndoRemoval').on('click', function(){",
" table.$('tr').removeClass('x').each(function(){",
" var td = $(this).find('td').eq(1)[0];",
" var cell = table.cell(td);",
" cell.data('ok');",
" });",
" Shiny.setInputValue('excludedRows', null);",
" });",
"}"
)
render <- c(
'function(data, type, row, meta){',
' if(type === "display"){',
' return "<span style=\\\"color:red; font-size:18px\\\"><i class=\\\"glyphicon glyphicon-" + data + "\\\"></i></span>";',
' } else {',
' return data;',
' }',
'}'
)
ui <- fluidPage(
tags$head(
tags$style(HTML(
".x { color: rgb(211,211,211); font-style: italic; }"
))
),
verbatimTextOutput("excludedRows"),
actionButton('SubmitRemoval', 'Exclude selected rows'),
actionButton('UndoRemoval', 'Include full data'),
br(),
DTOutput('mytable')
)
server <- function(input, output,session) {
dat <- cbind(Selected = "ok", mtcars[1:6,], id = 1:6)
output[["mytable"]] <- renderDT({
datatable(dat,
extensions = "Select",
options = list(
initComplete = JS(initComplete),
rowId = JS(sprintf("function(data){return data[%d];}", ncol(dat))),
columnDefs = list(
list(visible = FALSE, targets = ncol(dat)),
list(className = "dt-center", targets = "_all"),
list(
targets = 1,
render = JS(render)
)
)
)
)
}, server = FALSE)
proxy <- dataTableProxy("mytable")
observeEvent(input[["UndoRemoval"]], {
proxy %>% selectRows(NULL)
})
output$excludedRows <- renderPrint({
input[["excludedRows"]]
})
}
shinyApp(ui, server)
How to give color to a given interval of rows of a DT table?
Something like this should do the job. Note that I coloured the rows 2:4 on purpose instead of 1:4 for more functionality:
library(shiny)
library(DT)
ui <- basicPage(
mainPanel(DT::dataTableOutput('mytable'))
)
server <- function(input, output,session) {
output$mytable = DT::renderDataTable(
DT::datatable(mtcars, options = list(
pageLength = 25,
rowCallback = JS('function(row, data, index, rowId) {',
'console.log(rowId)','if(rowId >= 1 && rowId < 4) {',
'row.style.backgroundColor = "pink";','}','}')
)
)
)
}
runApp(list(ui = ui, server = server))
Edit: Dynamically colour rows: here I simply used sub to substitute for the range to colour the rows
library(shiny)
library(DT)
fnc <- JS('function(row, data, index, rowId) {',
'console.log(rowId)','if(rowId >= ONE && rowId < TWO) {',
'row.style.backgroundColor = "pink";','}','}')
ui <- basicPage(
sliderInput("colorrows", "Which to color:",min = 0, max = 10, value = c(1,3)),
mainPanel(DT::dataTableOutput('mytable'))
)
server <- function(input, output,session) {
Coloring <- eventReactive(input$colorrows,{
fnc <- sub("ONE",input$colorrows[1],fnc)
fnc <- sub("TWO",input$colorrows[2],fnc)
fnc
})
output$mytable = DT::renderDataTable(
DT::datatable(mtcars, options = list(pageLength = 25,rowCallback = Coloring())
)
)
}
runApp(list(ui = ui, server = server))
How to avoid mixup between rowcallback and sorting in datatable
The num you are using in your javascript to select rows to gray out is based on the row number on the current display so not impacted by sorting.
You could try replacing your if statement in your rowCallbackMeta function by:
if(data[0].search('remove') > -1)
This looks for "remove" in the first column of the data to exclude rows, and works because your glyphicon in the first column is updated to <i class="glyphicon glyphicon-remove"></i> when you exclude rows.
Copy/delete rows in two datatables (package: DT) in an rmarkdown HTML-document using JS
I've done the first part: moving the selected rows. This should help you to do the other parts. Ping me if you have a question.
---
title: ""
output:
html_document:
self_contained: false
---
```{r, include=FALSE}
knitr::opts_chunk$set(
fig.width=8, fig.height=6, echo=FALSE, warning=FALSE, message=FALSE
)
library(DT)
library(dplyr)
```
***
<div class = "row">
<div class = "col-md-6">
<button id="btn_move" type="button" class="btn btn-default btn-sm">
<span class="glyphicon glyphicon-arrow-right" aria-hidden="true"></span> Move selected rows in table 1 to table 2
</button>
```{r , echo = FALSE}
library(DT)
dt1 = mtcars[1:5,1:3]
dt2 = dt1
callback1 <- c(
"var table2;",
"setTimeout(function(){table2 = $('#table2').find('table').DataTable();});",
"$('#btn_move').on('click', function(){",
" var selectedRows = table.rows({selected: true});",
" var indices = selectedRows[0];",
" var rowsData = selectedRows.data();",
" for(var i=0; i<indices.length; i++){",
" var data = rowsData[i];",
" table2.row.add(data).draw();",
" table.row(indices[i]-i).remove().draw();",
" }",
"});"
)
datatable(dt1,
elementId = "table1",
caption = "Table 1",
extensions = "Select",
selection = "none",
callback = JS(callback1),
options = list(
select = list(style = "multi"),
dom = "t"
)
)
```
</div>
<div class = "col-md-6">
<button type="button" class="btn btn-default btn-sm">
Remove selected rows in table 2
</button>
<button type="button" class="btn btn-default btn-sm">
Remove all rows in table 2
</button>
```{r , echo = FALSE}
datatable(dt2 %>% slice(1),
caption = "Table 2",
elementId = "table2",
extensions = c("Select", "Buttons"),
selection = "none",
options = list(
select = list(style = "multi"),
dom = "tB",
buttons = list(
list(
title = NULL,
extend = "excel",
text = 'Save as Excel',
filename = "selected_variables"
)
)
)
)
```
</div>
Move javascript functionality of buttons to embedded buttons with DT datatable
The argument dt of the button action function (function(e,dt,node,config)) is the DataTables instance API for the host DataTable: https://datatables.net/reference/option/buttons.buttons.action
In the initComplete function function(settings), this object is settings.oInstance.api(), which is named table in the JS code (var table = settings.oInstance.api();).
So replace function(e,dt,node,config) with function(e,table,node,config), and move the JS code to the body of the button action function:
action = DT::JS(
c(
"function ( e, table, node, config ) {",
" var cross = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-remove\"></i></span>'",
" table.$('tr.selected').addClass('x');",
" table.$('tr.selected')",
" .each(function(){$(this).find('td').eq(1).html(cross);});",
"}"
)
)
EDIT
Here is the full code for the updated solution:
library(shiny)
library(DT)
removal <- c(
"function(e, table, node, config) {",
" table.$('tr.selected').addClass('x').each(function(){",
" var td = $(this).find('td').eq(1)[0];",
" var cell = table.cell(td);",
" cell.data('remove');",
" });",
" table.rows().deselect();",
" var excludedRows = [];",
" table.$('tr').each(function(i, row){",
" if($(this).hasClass('x')){excludedRows.push(parseInt($(row).attr('id')));}",
" });",
" Shiny.setInputValue('excludedRows', excludedRows);",
"}"
)
restore <- c(
"function(e, table, node, config) {",
" table.$('tr').removeClass('x').each(function(){",
" var td = $(this).find('td').eq(1)[0];",
" var cell = table.cell(td);",
" cell.data('ok');",
" });",
" Shiny.setInputValue('excludedRows', null);",
"}"
)
render <- c(
'function(data, type, row, meta){',
' if(type === "display"){',
' return "<span style=\\\"color:red; font-size:18px\\\"><i class=\\\"glyphicon glyphicon-" + data + "\\\"></i></span>";',
' } else {',
' return data;',
' }',
'}'
)
ui <- fluidPage(
tags$head(
tags$style(HTML(
".x { color: rgb(211,211,211); font-style: italic; }"
))
),
fluidRow(
column(
6,
tags$label("Excluded rows"),
verbatimTextOutput("excludedRows")
),
column(
6,
tags$label("Included rows"),
verbatimTextOutput("includedRows")
)
),
br(),
DTOutput('mytable')
)
server <- function(input, output,session) {
dat <- cbind(Selected = "ok", mtcars[1:6,], id = 1:6)
output[["mytable"]] <- renderDT({
datatable(dat,
extensions = c("Select", "Buttons"),
options = list(
rowId = JS(sprintf("function(data){return data[%d];}", ncol(dat))),
columnDefs = list(
list(visible = FALSE, targets = ncol(dat)),
list(className = "dt-center", targets = "_all"),
list(targets = 1, render = JS(render))
),
dom = "B",
buttons = list("copy", "csv",
list(
extend = "collection",
text = 'Deselect',
action = JS(removal)
),
list(
extend = "collection",
text = 'Restore',
action = JS(restore)
)
)
)
)
}, server = FALSE)
output$excludedRows <- renderPrint({
input[["excludedRows"]]
})
output$includedRows <- renderPrint({
setdiff(1:nrow(dat), input[["excludedRows"]])
})
}
shinyApp(ui, server)
"Deselect" from shiny server: example
library(shiny)
library(DT)
library(shinyjs)
js <- paste(
"var table = $('#mytable').find('table').DataTable();",
"var rowsindices = [%s];",
"for(var i=0; i<rowsindices.length; ++i){",
" var idx = rowsindices[i];",
" table.cell(idx, 1).data('remove');",
" table.row(idx).select();",
"}",
"$('.dt-button.buttons-collection').eq(0).click();",
sep = "\n"
)
removal <- c(
"function(e, table, node, config) {",
" table.$('tr.selected').addClass('x').each(function(){",
" var td = $(this).find('td').eq(1)[0];",
" var cell = table.cell(td);",
" cell.data('remove');",
" });",
" table.rows().deselect();",
" var excludedRows = [];",
" table.$('tr').each(function(i, row){",
" if($(this).hasClass('x')){excludedRows.push(parseInt($(row).attr('id')));}",
" });",
" Shiny.setInputValue('excludedRows', excludedRows);",
"}"
)
restore <- c(
"function(e, table, node, config) {",
" table.$('tr').removeClass('x').each(function(){",
" var td = $(this).find('td').eq(1)[0];",
" var cell = table.cell(td);",
" cell.data('ok');",
" });",
" Shiny.setInputValue('excludedRows', null);",
"}"
)
render <- c(
'function(data, type, row, meta){',
' if(type === "display"){',
' return "<span style=\\\"color:red; font-size:18px\\\"><i class=\\\"glyphicon glyphicon-" + data + "\\\"></i></span>";',
' } else {',
' return data;',
' }',
'}'
)
ui <- fluidPage(
useShinyjs(),
tags$head(
tags$style(HTML(
".x { color: rgb(211,211,211); font-style: italic; }"
))
),
fluidRow(
column(
6,
tags$label("Excluded rows"),
verbatimTextOutput("excludedRows")
),
column(
6,
tags$label("Included rows"),
verbatimTextOutput("includedRows")
)
),
br(),
actionButton("go", "Deselect rows 1, 2, 3"),
br(),
DTOutput('mytable')
)
server <- function(input, output,session) {
dat <- cbind(Selected = "ok", mtcars[1:6,], id = 1:6)
output[["mytable"]] <- renderDT({
datatable(dat,
extensions = c("Select", "Buttons"),
options = list(
rowId = JS(sprintf("function(data){return data[%d];}", ncol(dat))),
columnDefs = list(
list(visible = FALSE, targets = ncol(dat)),
list(className = "dt-center", targets = "_all"),
list(targets = 1, render = JS(render))
),
dom = "B",
buttons = list("copy", "csv",
list(
extend = "collection",
text = 'Deselect',
action = JS(removal)
),
list(
extend = "collection",
text = 'Restore',
action = JS(restore)
)
)
)
)
}, server = FALSE)
output$excludedRows <- renderPrint({
input[["excludedRows"]]
})
output$includedRows <- renderPrint({
setdiff(1:nrow(dat), input[["excludedRows"]])
})
observeEvent(input[["go"]], {
rows <- c(1,2,3) - 1
runjs(sprintf(js, paste0(rows, collapse=",")))
})
}
shinyApp(ui, server)
Add checked icon to selected rows in DT shiny
Thanks to @StéphaneLaurent 's answer which is a great js based solution and solved my 95% needs. However I need a button to clear all selection and cannot write that one because of my limited js skills. I also forgot the important server=FALSE parameter so met problem of sorting lost selection. Thus I switched back to my original row selection mechanism.
I used to try to modify the table by row selection, but that will trigger reactive event loop. Later I realized I only need to change the view, not the underlying data, and changing view is possible by purely css rules.
Checking the great example here, the more icons example can show different icon depend on checkbox selection. By inspecting the css rules, I found both icons are there all the time, just the css rule is different depend on selection status.
Thus I came up with this solution, which used the builtin row selection in DT and some css rules, this way you still have all the feature of row selection control in DT without needs of js code, and everything is implemented by css.
library(shiny)
library(DT)
library(data.table)
ui <- fluidPage(
tags$head(
tags$style(HTML("
.selected .table-icon-yes {
opacity: 1;
display: inline-block;
color: #3c763d;
}
.table-icon-yes {
opacity: 0;
display: none;
}
.selected .table-icon-no {
opacity: 0;
display: none;
}
.table-icon-no {
opacity: 1;
display: inline-block;
color: #999;
}
"))
),
DTOutput("table")
)
icon_col <- tagList(span(class = "table-icon-yes", icon("ok", lib = "glyphicon")),
span(class = "table-icon-no", icon("remove", lib = "glyphicon")))
server <- function(input, output, session) {
output$table <- renderDT({
dt <- data.table(iris)
dt[, Selected := as.character(icon_col)]
setcolorder(dt, c(ncol(dt), 1:(ncol(dt) - 1)))
datatable(dt, escape = FALSE)
})
}
shinyApp(ui = ui, server = server)
Is there a way to generate a select none Button in a DT::datatable() without shiny?
This works:
library(DT)
datatable(iris,
extensions = c("Buttons", "Select"),
options = list(
dom = 'Bfrtip',
select = TRUE,
buttons = list(
"copy", "selectNone"
)
)
)
If you want to change the label of the button:
datatable(iris,
extensions = c("Buttons", "Select"),
options = list(
dom = 'Bfrtip',
select = TRUE,
buttons = list(
"copy",
list(
extend = "selectNone",
text = "Select none"
)
)
)
)
Related Topics
Logistic Regression: How to Try Every Combination of Predictors in R
Sum Columns by Group (Row Names) in a Matrix
Reshape R Data with User Entries in Rows, Collapsing for Each User
Function for Polynomials of Arbitrary Order (Symbolic Method Preferred)
Cannot Install Stringi Since Xcode Command Line Tools Update
How to Embed Plots into a Tab in Rmarkdown in a Procedural Fashion
Out of Order Text Labels on Stack Bar Plot (Ggplot)
Rolling by Group in Data.Table R
R: How to Judge Date in the Same Week
Why Does "Hello" > 0 Return True
Get Rows of Unique Values by Group
R: Removing Duplicate Elements in a Vector
R: How to Retrieve a Column Name of a Data Frame
Transform One Column from Categoric to Binary, Keep the Rest
Control Padding of Grobs Added to Patchwork
R Convert String Date (E.G. "October 1, 2014") to Date Format