Как отформатировать фон DT * на строку *?

Question

Я хочу использовать DT * formatStyle(), чтобы задать цветовой градиент на строку .

Учитывая данные этого примера:

library(DT)

data <- round(data.frame(
  x = runif(5, 0, 5),
  y = runif(5, 0, 10), 
  z = runif(5, 0, 20)
), 3)

break_points <- function(x) stats::quantile(x, probs = seq(.05, .95, .05), na.rm = TRUE)
red_shade <- function(x) round(seq(255, 40, length.out = length(x) + 1), 0) %>% {paste0("rgb(255,", ., ",", ., ")")}

Я могу покрасить ячейкуфоны, основанные на значениях во всей таблице с использованием этого кода:

brks <- break_points(data)
clrs <- red_shade(brks)
datatable(data) %>% formatStyle(names(data), backgroundColor = styleInterval(brks, clrs))

Или я могу покрасить фон ячейки на основе значений для столбца с помощью этого кода:

brks <- apply(data, 2, break_points)
clrs <- apply(brks, 2, red_shade)
dt <- datatable(data)
for(i in colnames(data)){
  dt <- dt %>% formatStyle(i, backgroundColor = styleInterval(brks[,i], clrs[,i]))
}
dt

Но я не уверен, какое самое простое чистое решение сделать это на строку , чтобы в каждом ряду самое высокое значение было самым темным, а нижнее - самым легким.

Answer 1

со строкой обратного вызова:

library(DT)

data <- round(data.frame(
  x = runif(10, 0, 5),
  y = runif(10, 0, 10), 
  z = runif(10, 0, 20)
), 3)

break_points <- function(x) stats::quantile(x, probs = seq(.05, .95, .05), na.rm = TRUE)
red_shade <- function(x) round(seq(255, 40, length.out = length(x) + 1), 0) %>% {paste0("rgb(255,", ., ",", ., ")")}

brks <- apply(data, 1, break_points)
clrs <- apply(brks, 2, red_shade)

rowCallback <- "function(row, data, displayNum, index){"

for(i in 1:ncol(data)){
  rowCallback <- c(
    rowCallback,
    sprintf("var value = data[%d];", i)
  )
  for(j in 1:nrow(data)){
    rowCallback <- c(
      rowCallback, 
      sprintf("if(index === %d){", j-1),
      sprintf("$('td:eq(%d)',row).css('background-color', %s);", 
              i, styleInterval(brks[,j], clrs[,j])),
      "}"
    )
  }
}
rowCallback <- c(rowCallback, "}")

datatable(data, options = list(rowCallback = JS(rowCallback)))