r - 有条件地设置 RowGroup 的样式

Question

是否可以设置 RowGroup 标题的样式？例如这里如何更改字体颜色:

library(DT)

mtcars2 = mtcars[1:20, ]
datatable(
  mtcars2[order(mtcars2$cyl), ],
  extensions = 'RowGroup',
  options = list(rowGroup = list(dataSrc = 2)),
  selection = 'none'
)

我找到了 this relevant question ，但我无法将答案应用于我的案例。
如果是 multi-level grouping ，如何仅设置特定组的标题的样式？

Answer 1

mtcars2 = mtcars[1:20, ]
datatable(
  mtcars2[order(mtcars2$cyl), ],
  extensions = 'RowGroup',
  options = list(
    rowGroup = list(
      dataSrc = 2,
      startRender = JS(
        "function(rows, group) {", 
        "  var style = group == 4 ? 'background-color: lime;' : 'background-color: crimson;';",
        "  var td = `<td style='${style}' colspan=12>${group}</td>`;",
        "  return $(`<tr>${td}</tr>`);",
        "}"
      )
    )
  ),
  selection = 'none'
)

奖金
这是一种自动设置行组标题样式的方法。它使用 JavaScript 库 d3-scale-chromatic用于调色板和 TinyColor检测颜色是深还是浅。

dat <- data.frame(
  Group = gl(10, 2, labels = LETTERS[1:10]),
  x1 = rpois(20, 100),
  x2 = rpois(20, 100),
  x3 = rpois(20, 100)
)

dtable <- datatable(
  dat,
  class = "compact",
  extensions = 'RowGroup',
  options = list(
    pageLength = 20,
    rowGroup = list(
      dataSrc = 1,
      startRender = JS(
        "function(rows, group) {", 
        "  var groups = this.s.dt.table().column(1).data().unique();",
        "  var t = groups.indexOf(group) / groups.length;",
        "  var bgcolor = d3.interpolateWarm(t);",
        "  var color = tinycolor(bgcolor).isDark() ? 'white' : 'black'",
        "  var style = `color: ${color}; background-color: ${bgcolor};`;",
        "  var ncol = this.s.dt.table().columns().count();",
        "  var td = `<td style='${style}' colspan=${ncol}>${group}</td>`;",
        "  return $(`<tr>${td}</tr>`);",
        "}"
      )
    )
  ),
  selection = 'none'
)

dep <- htmltools::htmlDependency(
  "d3-scale-chromatic", "1.5.0",
  c(href =  "https://d3js.org/"), 
  script = c(
    "d3-color.v1.min.js", 
    "d3-interpolate.v1.min.js",
    "d3-scale-chromatic.v1.min.js"
  )
)
dtable$dependencies <- c(dtable$dependencies, list(dep))
dep <- htmltools::htmlDependency(
  "TinyColor", "1.4.1",
  c(href =  "https://cdn.jsdelivr.net/gh/bgrins/TinyColor/"), 
  script = "tinycolor.js"
)
dtable$dependencies <- c(dtable$dependencies, list(dep))

dtable

编辑
如果您有嵌套组，以下是仅将样式应用于第二级的方法:

mtcars2 = mtcars[1:20, ]
datatable(
  mtcars2[order(mtcars2$cyl), ],
  extensions = 'RowGroup',
  options = list(
    rowGroup = list(
      dataSrc = c(2,11),
      startRender = JS(
        "function(rows, group, level) {", 
        "  if(level == 1) {",
        "    var style = 'background-color: lime;'",
        "    var td = `<td style='${style}' colspan=12>${group}</td>`;",
        "    return $(`<tr>${td}</tr>`);",
        "  }else{",
        "    return group;",
        "  }",
        "}"
      )
    )
  ),
  selection = 'none'
)