将颜色动态应用于 R 中的表格单元格答案

【问题标题】：Applying colors dynamically to table cells in R将颜色动态应用于 R 中的表格单元格
【发布时间】：2020-05-19 06:56:52
【问题描述】：

我在 R 中有一个如下所示的数据框：

它高 84 行，宽 365 行。输出如下。我想弄清楚的是如何让每个单元格根据单元格中的符号改变颜色（另外，我不想看到列名、行名或网格线）。我试过 kable、DT、base R、heatmap 和 huxtable。我得到的最接近的是 DT：

datatable(cover, rownames=FALSE, options = list(dom = 't')) %>% formatStyle(names(cover), backgroundColor=styleEqual(hex$Symbol, hex$Hex))

这是该代码的结果：

我无法弄清楚如何同时删除列名（因此列仅与符号一样宽）或网格线。我确信有办法做到这一点，但我已经旋转了几天，所以我想我会问专家。我对 R 还是很陌生（我是数据分析师，而不是专业编码员）。我的最终目标是让它看起来像这样（使用 Google 表格条件格式创建）：

数据表前10列头部的dput：

structure(list(`2019-01-01` = c("f", "f", "f", "<U+263D>", "<U+263D>", "<U+263D>"), `2019-01-02` = c("<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>"), `2019-01-03` = c("t", "t", "t", "d", "d", "d"), `2019-01-04` = c("d", "d", "d", "<U+2699>", "<U+2699>", "<U+2699>"), `2019-01-05` = c("&", "&", "&", "&", "&", "&"), `2019-01-06` = c("<U+2699>", "<U+2699>", "<U+2699>", "&", "&", "&"), `2019-01-07` = c("^", "^", "^", "^", "^", "^"), `2019-01-08` = c("&", "&", "&", "<U+270E>", "<U+270E>", "<U+270E>"), `2019-01-09` = c("<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>"), `2019-01-10` = c("s", "s", "s", "s", "s", "s")), row.names = c(NA, 6L), class = "data.frame")

符号到十六进制查找表的输入：

structure(list(Symbol = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "a","i", "k", "b", "l", "r", "c", "x", "@", "%", "^", "e", "m", "s", "#", "<U+270E>", "&", "<U+2699>", "d", "t", "y", "n", "<U+25C0>", "<U+263D>", "f", "<U+2689>", "<U+2726>", "<U+0394>", "¥", "p", "u", "<U+2326>", "<U+26AF>", "z", "<U+2714>", "o", "+", "v", "g", "<U+262F>", "<U+2724>", "<U+272B>", "<U+2766>", "j", "q", "h", "<U+2665>", "w"), Hex = c("#572433", "#72375D", "#633666", "#803A6B", "#6C3A6E", "#776B98", "#ADA7C7", "#5C7294", "#7B8EAB", "#707DA2", "#555B7B", "#464563", "#0E365C", "#11416D", "#13477D", "#2C597C", "#396987", "#4781A5", "#35668B", "#5A8FB8", "#3B768F", "#4F93A7", "#5BA3B3", "#90C3CC", "#C4DECC", "#7BAC94", "#5B9071", "#396F52", "#044D33", "#313919", "#424D21", "#4C5826", "#72843C", "#94AB4F", "#AEBF79", "#CCD9B1", "#D8E498", "#FFFB8B", "#FDF9CD", "#FFF1AF", "#FDD755", "#FFC840", "#FFBF57", "#FFA32B", "#FF8B00", "#F67F00", "#F27842", "#FF836F", "#E96A67", "#FF7992", "#E74967", "#BA4A4A", "#B33B4B", "#970B23", "#87071F", "#A7132B", "#913546")), row.names = c(NA, -57L), spec = structure(list(cols = list(Index = structure(list(), class = c("collector_double", "collector")), Color = structure(list(), class = c("collector_double", "collector")), `Color name` = structure(list(), class = c("collector_character", "collector")), Symbol = structure(list(), class = c("collector_character", "collector")), Hex = structure(list(), class = c("collector_character", "collector"))), default = structure(list(), class = c("collector_guess", "collector")), skip = 1), class = "col_spec"), class = c("spec_tbl_df", "tbl_df", "tbl", "data.frame"))

这是我根据下面的 cmets 使用的代码。上周有效，但现在无效。我已经逐行确定 value2 没有正确渲染，但我已经根据提供的代码检查了它，它看起来完全一样。我称数据集为“封面”，颜色表为“十六进制”。

hexcol <- hex$Hex
names(hexcol) <- hex$Symbol
bcol <- function(x){hexcol[as.character(x)]}

x <- cover %>%
  dplyr::mutate(row.id = 1:n()) %>%
  gather(key = "key", value = "value", -row.id) %>%
  mutate(value2 = "  ", value2 = cell_spec(value2, background = mapply(bcol, value), color = mapply(bcol, value))) %>%
  select(-value) %>%
  spread(key = key, value = value2) %>%
  select(-row.id) %>%
  kable(format = "html", escape = F) %>%
  kable_styling(full_width = F)
x2 <- gsub("<thead>.*</thead>", "", x)
x3.splits <- unlist(str_split(x2, pattern = "\n"))
x3.cols <- str_extract(x3.splits, pattern = "#[0-9a-fA-F]{6}")
x3.vals <- str_extract(x3.splits, pattern = "(a-Z0-9)+")

# cycle through each row of HTML code to find and replace any value with HTML/CSS code to color the background of that specific cell
for (i in 1:length(x3.splits)){
  if (!is.na(x3.cols[i])){
    x2 <- gsub(pattern = x3.splits[i], 
               replacement = paste0('<td style="text-align:center; background-color: ', x3.cols[i], '; border-top: 1px solid ', 
                                    x3.cols[i], ';"><span style="margin-left:5px;margin-right:5px">   </span></td>'), x = x2)
  }
}

这是会话信息：

【问题讨论】：

我运行了您在我的设备上发布的代码，但它似乎仍然对我有用 - 当您说它不呈现时，它是否会引发任何类型的错误或颜色没有显示RStudio？
颜色只是没有出现在 RStudio 中。当我运行 x2 时，它只显示一堆没有背景的线条。
您可以运行sessionInfo() 并将结果粘贴到您的问题中吗？

标签： r colors dt

【解决方案1】：

您是否尝试过使用kableExtra 包？我能够执行以下操作，我认为可以使用此包以及一些 HTML 语法/正则表达式替换来完成您希望执行的操作。如果这似乎对你不起作用，请告诉我！

library(kableExtra)
library(stringr)
library(dplyr)
library(tidyr)
library(magick)
library(webshot)

dat <- structure(list(`2019-01-01` = c("f", "f", "f", "<U+263D>", "<U+263D>", "<U+263D>"), `2019-01-02` = c("<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>"), `2019-01-03` = c("t", "t", "t", "d", "d", "d"), `2019-01-04` = c("d", "d", "d", "<U+2699>", "<U+2699>", "<U+2699>"), `2019-01-05` = c("&", "&", "&", "&", "&", "&"), `2019-01-06` = c("<U+2699>", "<U+2699>", "<U+2699>", "&", "&", "&"), `2019-01-07` = c("^", "^", "^", "^", "^", "^"), `2019-01-08` = c("&", "&", "&", "<U+270E>", "<U+270E>", "<U+270E>"), `2019-01-09` = c("<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>"), `2019-01-10` = c("s", "s", "s", "s", "s", "s")), row.names = c(NA, 6L), class = "data.frame")

col.tab <- structure(list(Symbol = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "a","i", "k", "b", "l", "r", "c", "x", "@", "%", "^", "e", "m", "s", "#", "<U+270E>", "&", "<U+2699>", "d", "t", "y", "n", "<U+25C0>", "<U+263D>", "f", "<U+2689>", "<U+2726>", "<U+0394>", "¥", "p", "u", "<U+2326>", "<U+26AF>", "z", "<U+2714>", "o", "+", "v", "g", "<U+262F>", "<U+2724>", "<U+272B>", "<U+2766>", "j", "q", "h", "<U+2665>", "w"), Hex = c("#572433", "#72375D", "#633666", "#803A6B", "#6C3A6E", "#776B98", "#ADA7C7", "#5C7294", "#7B8EAB", "#707DA2", "#555B7B", "#464563", "#0E365C", "#11416D", "#13477D", "#2C597C", "#396987", "#4781A5", "#35668B", "#5A8FB8", "#3B768F", "#4F93A7", "#5BA3B3", "#90C3CC", "#C4DECC", "#7BAC94", "#5B9071", "#396F52", "#044D33", "#313919", "#424D21", "#4C5826", "#72843C", "#94AB4F", "#AEBF79", "#CCD9B1", "#D8E498", "#FFFB8B", "#FDF9CD", "#FFF1AF", "#FDD755", "#FFC840", "#FFBF57", "#FFA32B", "#FF8B00", "#F67F00", "#F27842", "#FF836F", "#E96A67", "#FF7992", "#E74967", "#BA4A4A", "#B33B4B", "#970B23", "#87071F", "#A7132B", "#913546")), row.names = c(NA, -57L), spec = structure(list(cols = list(Index = structure(list(), class = c("collector_double", "collector")), Color = structure(list(), class = c("collector_double", "collector")), `Color name` = structure(list(), class = c("collector_character", "collector")), Symbol = structure(list(), class = c("collector_character", "collector")), Hex = structure(list(), class = c("collector_character", "collector"))), default = structure(list(), class = c("collector_guess", "collector")), skip = 1), class = "col_spec"), class = c("spec_tbl_df", "tbl_df", "tbl", "data.frame"))

color_mapper <- col.tab$Hex
names(color_mapper) <- col.tab$Symbol
c_func <- function(x){
  color_mapper[as.character(x)]


}

x <- dat %>%
  mutate(row.id = 1:n()) %>%
  gather(key = "key", value = "value", -row.id) %>%
  mutate(value2 = "  ",
         value2 = cell_spec(value2, background = mapply(c_func, value), color = mapply(c_func, value))
         ) %>%
  select(-value) %>%
  spread(key = key, value = value2) %>%
  select(-row.id) %>%
  kable(format = "html", escape = F) %>%
  kable_styling(full_width = F)

x2 <- gsub("<thead>.*</thead>", "", x)

x3.splits <- unlist(str_split(x2, pattern = "\n"))
x3.cols <- str_extract(x3.splits, pattern = "#[0-9a-fA-F]{6}")
x3.vals <- str_extract(x3.splits, pattern = "(a-Z0-9)+")

## cycle through each row of HTML code to find and replace any value with
## HTML/CSS code to color the background of that specific cell
for (i in 1:length(x3.splits)){
  if (!is.na(x3.cols[i])){
    x2 <- gsub(
      pattern = x3.splits[i],
      replacement = paste0('<td style="text-align:center; background-color: ', x3.cols[i], '; border-top: 1px solid ', x3.cols[i], ';"><span style="margin-left:5px;margin-right:5px">   </span></td>'),
      x = x2
    )
  }
}
x2 %>%
  save_kable("my_image.png")

使用 PNG 输出：

【讨论】：

谢谢！这确实最终呈现，但运行确实需要很长时间。我可以做些什么来提高效率（花更少的时间来处理）？另外，我注意到 kable 有它在 HTML 中呈现。我之前忘了提到这一点，但我正在尝试使用 rmarkdown 将其呈现为 PDF。有没有办法减小整个东西的大小，使其适合页面的宽度？
看来您可以follow the instructions here 设置kableExtra 将表格输出直接保存为PNG 图像或PDF。我想我建议保存为 PNG 或使用 as_image() 函数直接在 rmarkdown 中呈现。我将更新我的代码来执行此操作，但如果您使用的是 Windows 设备，您需要确保安装正确的依赖项（webshot 和 magick）以及 GhostScript。
好的，它上周工作（缓慢），现在我使用相同的代码，由于某种原因 value2 上的格式没有呈现。我尝试粘贴我的代码，但它太长了？我如何在 cmets 中做到这一点。
您可以编辑您的原始问题 - 或使用更新的问题添加到问题的底部
谢谢！我已经添加到我原来的问题。

【解决方案2】：

这是一个使用 huxtable 的简单示例（我是包作者）：

tmp <- structure(list(`2019-01-01` = c("f", "f", "f", "<U+263D>", "<U+263D>", "<U+263D>"), `2019-01-02` = c("<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>"), `2019-01-03` = c("t", "t", "t", "d", "d", "d"), `2019-01-04` = c("d", "d", "d", "<U+2699>", "<U+2699>", "<U+2699>"), `2019-01-05` = c("&", "&", "&", "&", "&", "&"), `2019-01-06` = c("<U+2699>", "<U+2699>", "<U+2699>", "&", "&", "&"), `2019-01-07` = c("^", "^", "^", "^", "^", "^"), `2019-01-08` = c("&", "&", "&", "<U+270E>", "<U+270E>", "<U+270E>"), `2019-01-09` = c("<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>"), `2019-01-10` = c("s", "s", "s", "s", "s", "s")), row.names = c(NA, 6L), class = "data.frame")

ht <- as_hux(tmp)
ht <- map_background_color(ht, by_values("<U+270E>" = "red", "<U+2699>" = "green"))

我没有使用你的确切符号表。如果它很大，您可能想要执行do.call(by_values, my_symbols) 之类的操作，其中my_symbols 将类似于list("1" = "#572433", ...)。

【讨论】：

我尝试了一个非常基本的版本，正如你上面提到的，看看它是否可以工作。我的代码中的“模式”就是您在上面定义为 tmp 的内容。我预计它将所有“k”符号更改为背景颜色，但它根本没有改变颜色。 ht <- as_hux(pattern) ht <- map_background_color(ht, by_values("k" = "#94AB4F"))
我是否需要一次添加所有颜色/符号映射才能使其工作？我希望在为所有人找出更复杂的版本之前先用其中一个进行验证。
我无法调试您的问题，因为您的示例数据中没有“k”。当您运行我的示例时，它有效吗？如您所见，我将您的示例数据复制到了tmp 变量中。
好的，我确实看到红色和绿色正在突出显示。您如何建议最好地应用 57 种颜色，使用查找表而不是像上面那样输入它们？另一个问题是我想将列缩小到一个字符的宽度（特别是那些作为代码传入的列，并将符号的字体与背景颜色相同。跨度>
您是否按照我的建议尝试过使用do.call(by_values, my_symbols)？然后，您需要将 my_symbols 设为 list() 而不是数据框。列表的名称应该是 unicode 符号（您需要引用它们）；这些值将是所需的颜色。类似于my_symbols = lookup_table$Hex; names(my_symbols) <- lookup_table$Symbol，其中lookup_table 是您在上面输入的表格。