Use several selection colors in DT::datatable? - css

Question

I have set:
output$tableId <-
DT::renderDataTable({DT::datatable(..., selection = "multiple")})
And I would like the background color of the selection to vary depending on of it's the first selection, or the second, etc.
It should be possible to use length(input$tableId_rows_selected) (which is described here) to obtain this behaviour? I'm guessing in combination with creating some CSS modifying this:
.table.dataTable tbody td.active, .table.dataTable tbody tr.active td {
background-color: #007bff;
color: white;
}
I know very little CSS, HTML, and JavaScript, so I find these things difficult.
EDIT 2022-02-14:
After #StéphaneLaurent initial answer below, I want to change my question slightly:
The logic I would prefer the most is:
We have m unique colors. n < m previous rows have been selected.
The n+1th row gets selected and is then coloured in the n+1th color and keeps this color until deselected.
When m rows are currently selected, no more selections are possible. Alternatively, I would also be interested in: When the m+1th row gets selected, it gets coloured in the first color, and other row occupying this color gets deselected. m+1 rows are now chosen, and when the m+2th row gets selected, it gets coloured in the second color, and the other row occupying this color gets deselected. And so on.
Moreover:
Since my app will be running through an iframe on a website, and the underlying data of the app will have 10 to 100 million observations, I think a solution where DT::renderDataTable({...}, server = TRUE) would be good.
I also want the solution to work with the DT::datatable(..., selection = list(mode = "multiple", selected = 1:3, target = "row")) option.
I will try to implement the above using #StéphaneLaurent answer, combined with the tools #YihuiXie illustrate here (app from page linked earlier).

Answer 1

If you use the following CSS, then the first row will be red if you select it, the second will be green, the third will be blue:
#dtable tbody tr.selected:nth-of-type(1) td {
box-shadow: inset 0 0 0 9999px red;
}
#dtable tbody tr.selected:nth-of-type(2) td {
box-shadow: inset 0 0 0 9999px green;
}
#dtable tbody tr.selected:nth-of-type(3) td {
box-shadow: inset 0 0 0 9999px blue;
}
Here dtable is the id.
library(shiny)
library(DT)
css <- "
#dtable tbody tr.selected:nth-of-type(1) td {
box-shadow: inset 0 0 0 9999px red;
}
#dtable tbody tr.selected:nth-of-type(2) td {
box-shadow: inset 0 0 0 9999px green;
}
#dtable tbody tr.selected:nth-of-type(3) td {
box-shadow: inset 0 0 0 9999px blue;
}
"
ui <- fluidPage(
tags$head(
tags$style(
HTML(css)
)
),
br(), br(),
DTOutput("dtable")
)
server <- function(input, output, session) {
output[["dtable"]] <- renderDT({
datatable(iris, selection = "multiple")
})
}
shinyApp(ui, server)
Here is how to generate the CSS for 100 rows with a random color, using the sass package. Save the following scss file, say mystyle.scss:
$s-min: 20;
$s-max: 70;
$l-min: 30;
$l-max: 90;
#for $i from 1 through 100 {
#dtable tbody tr.selected:nth-of-type(#{$i}) td {
box-shadow: inset 0 0 0 9999px hsl(random(360),$s-min+random($s-max+-$s-min),$l-min+random($l-max+-$l-min));
}
}
Now compile it to a CSS file:
library(sass)
sass(sass_file("mystyle.scss"), output = "mystyle.css")
Put the file mystyle.css in the www subfolder of the app, and then include it in the app as follows:
ui <- fluidPage(
tags$head(
tags$link(
href = "mystyle.css", rel = "stylesheet"
)
),
......
EDIT : jQuery solution
library(shiny)
library(DT)
js <- '
var colors = ["red", "green", "blue", "yellow", "purple"];
table.on("select", function(e, dt, type, indexes) {
var count = table.rows({selected: true}).count();
for(var i = 0; i < count; i++) {
$("#dtable tbody tr.selected").eq(i).find("td").css(
"box-shadow", "inset 0 0 0 9999px " + colors[i]
);
}
}).on("deselect", function(e, dt, type, indexes) {
for(var i = 0; i < indexes.length; i++) {
$("#dtable tbody tr").eq(indexes[i]).find("td").css(
"box-shadow", ""
);
}
var count = table.rows({selected: true}).count();
for(var i = 0; i < count; i++) {
$("#dtable tbody tr.selected").eq(i).find("td").css(
"box-shadow", "inset 0 0 0 9999px " + colors[i]
);
}
});
'
ui <- fluidPage(
br(), br(),
DTOutput("dtable")
)
server <- function(input, output, session) {
output[["dtable"]] <- renderDT({
datatable(
iris,
extensions = "Select",
selection = "none",
callback = JS(js),
options = list(
"select" = "multi"
)
)
}, server = FALSE)
}
EDIT: correction of previous edit
Here is the correct JS code:
js <- '
var colors = ["red", "green", "blue", "yellow", "purple"];
var stack = [];
table.on("select", function(e, dt, type, indexes) {
stack.push(indexes[0]);
for(var i = 0; i < stack.length; i++) {
$("#dtable tbody tr").eq(stack[i]).find("td").css(
"box-shadow", "inset 0 0 0 9999px " + colors[i]
);
}
}).on("deselect", function(e, dt, type, indexes) {
var i0 = stack.indexOf(indexes[0]);
$("#dtable tbody tr").eq(stack[i0]).find("td").css(
"box-shadow", ""
);
stack.splice(i0, 1);
for(var i = 0; i < stack.length; i++) {
$("#dtable tbody tr").eq(stack[i]).find("td").css(
"box-shadow", "inset 0 0 0 9999px " + colors[i]
);
}
});
'
EDIT: without the 'Select' extension
js <- '
var colors = ["red", "green", "blue", "yellow", "purple"];
var stack = [];
table.on("click", "tr", function() {
var $rows = $("#dtable tbody tr"); // SIMONSIMON I moved this line
var $row = $(this);
var idx = $row.index();
if($row.hasClass("selected")) {
stack.push(idx);
for(var i = 0; i < stack.length; i++) {
$rows.eq(stack[i]).find("td").css(
"box-shadow", "inset 0 0 0 9999px " + colors[i]
);
}
} else {
var i0 = stack.indexOf(idx);
$rows.eq(stack[i0]).find("td").css(
"box-shadow", ""
);
stack.splice(i0, 1);
for(var i = 0; i < stack.length; i++) {
$rows.eq(stack[i]).find("td").css(
"box-shadow", "inset 0 0 0 9999px " + colors[i]
);
}
}
});
'
......
output[["dtable"]] <- renderDT({
datatable(
iris,
selection = "multiple",
callback = JS(js)
)
}, server = TRUE)

Answer 2

While technically this doesn't do what I originally requested (i.e. changing the selection colouring dynamically), the results from this implementation appear visually similar to the end-user.
The idea behind the solution is to keep track of the row selection counter, update the table via a proxy, and apply conditional formatting.
library(shiny)
library(data.table)
library(DT)
data(iris)
iris <- suppressWarnings(cbind(as.data.table(iris),
currently_selected = numeric(),
selected_as_nr = numeric(),
overwrite = numeric()))
ui <- fluidPage(
dataTableOutput("table"),
)
server <- function(input, output, session) {
iris[, currently_selected := 0]
iris[, selected_as_nr := NA]
iris[, overwrite := 0]
output$table <- DT::renderDataTable({
DT::datatable(iris,
selection = list(mode = "multiple",
selected = 1,
target = "row")) %>%
formatStyle("Sepal.Length",
"selected_as_nr",
backgroundColor = styleEqual(0:4, c("green",
"red",
"black",
"blue",
"yellow")))
})
proxy <- dataTableProxy(outputId = "table")
observeEvent(input$table_rows_selected, {
new_selected_row <- input$table_rows_selected[1]
iris[new_selected_row, currently_selected := (currently_selected + 1) %% 2]
if (iris[new_selected_row, currently_selected] == 1) {
new_selection_nr <- suppressWarnings(iris[, min(setdiff(0:4, unique(selected_as_nr)))])
if (new_selection_nr != "Inf") {
iris[, overwrite := 0]
iris[new_selected_row, selected_as_nr := new_selection_nr]
} else {
overwrite <- iris[, unique(overwrite)]
iris[selected_as_nr == overwrite, currently_selected := 0]
iris[selected_as_nr == overwrite, selected_as_nr := NA]
iris[new_selected_row, selected_as_nr := overwrite]
iris[, overwrite := (overwrite + 1) %% 5]
}
} else {
iris[new_selected_row, selected_as_nr := NA]
}
DT::replaceData(proxy, iris)
})
}
shinyApp(ui, server)