如何在 R 中创建动态 HTML table
How to create dynamic HTML table in R
我在 R 中使用以下结构化数据框。
数据框<-
seq count percentage Marking count Percentage batch_no count Percentage
FRD 1 12.50% S1 2 25.00% 6 1 12.50%
FHL 1 12.50% S2 1 12.50% 7 2 25.00%
ABC 2 25.00% S3 1 12.50% 8 2 25.00%
DEF 1 12.50% Hold 2 25.00% 9 1 12.50%
XYZ 1 12.50% NA 1 12.50% NA 1 12.50%
ZZZ 1 12.50% (Blank) 1 12.50% (Blank) 1 12.50%
FRD 1 12.50% - - - - - -
NA 1 12.50% - - - - - -
(Blank) 0 0.00% - - - - - -
Total 8 112.50% - 8 100.00% - 8 100.00%
数据框的列数是静态的，但行数可以变化。例如，某些条件下的行数可能是 15 或更少，可能是 4 或 5。
我需要添加 table header 颜色为浅绿色加粗字体，最后一行 table 颜色为黄色加粗字体。另外，需要添加条件，如果Percentage of Hold in marking and Percentage of 8 in batch_no is >25% mark it as a dark red with bold white font.
如果可能的话，我们可以在S3中添加后缀为S3 (In Progress)和9作为`9（进行中）其中（进行中）的字体将是2字体小于变量名.
添加的文字(In Progress)应为黄色加粗字体。
我正在使用下面提到的代码：
library(tableHTML)
library(dplyr)
add_font <- function(x) {
x <- gsub('\(', '\(<font size="-1">', x)
x <- gsub('\)', '</font>\)', x)
return(prettyNum(x, big.mark = ','))
}
Html_Table<-Dataframe %>%
mutate(`Marking` = add_font(`Marking`),
`batch_no` = add_font(`batch_no`)) %>%
tableHTML(rownames = FALSE,
escape = FALSE,
widths = rep(100, 12),
caption = "Dataframe: Test",
theme='scientific') %>%
add_css_caption(css = list(c("font-weight", "border","font-size"),
c("bold", "1px solid black","16px"))) %>%
add_css_row(css = list(c("background-color"), c("lightblue")), rows = 0:1)%>%
add_css_caption(css = list(c("background-color"), c("lightblue"))) %>%
add_css_row(css = list('background-color', '#f2f2f2'),
rows = odd(1:10)) %>%
add_css_row(css = list('background-color', '#e6f0ff'),
rows = even(1:10)) %>%
add_css_row(css = list(c("background-color","font-weight"), c("yellow", "bold")),
rows = even(2:3)) %>%
add_css_row(css = list(c("font-style","font-size"), c("italic","12px")),
rows = 4:8)
这是一个使用 kableExtra 而不是 htmlTable...
的解决方案
library(tidyverse)
library(knitr)
library(kableExtra)
Dataframe<-
tribble(
~seq, ~count1, ~percentage1, ~Marking, ~count2, ~Percentage2, ~batch_no, ~count3, ~Percentage3,
"FRD", 1, "12.50%", "S1", "2", "25.00%", "6", "1", "12.50%",
"FHL", 1, "12.50%", "S2", "1", "12.50%", "7", "2", "25.00%",
"ABC", 2, "25.00%", "S3", "1", "12.50%", "8", "2", "45.00%",
"DEF", 1, "12.50%", "Hold", "2", "45.00%", "9", "1", "12.50%",
"XYZ", 1, "12.50%", "NA", "1", "12.50%", "NA", "1", "12.50%",
"ZZZ", 1, "12.50%", "(Blank)", "1", "12.50%", "(Blank)", "1", "12.50%",
"FRD", 1, "12.50%", "-", "-", "-", "-", "-", "-",
"NA", 1, "12.50%", "-", "-", "-", "-", "-", "-",
"(Blank)", 0, "0.00%", "-", "-", "-", "-", "-", "-",
"Total", 8, "112.50%", "-", "8", "100.00%", "-", "8", "100.00%"
)
test1 <- expression(Marking == "Hold" & as.numeric(str_remove(Percentage2, "%")) > 25.00)
test2 <- expression(batch_no == "8" & as.numeric(str_remove(Percentage3, "%")) > 25.00)
Dataframe %>%
mutate(Percentage2 = cell_spec(Percentage2,
"html",
background = ifelse(eval(test1), "red", ""),
color = ifelse(eval(test1), "white", "black")),
Percentage3 = cell_spec(Percentage3,
"html",
background = ifelse(eval(test2), "red", ""),
color = ifelse(eval(test2), "white", "black"))) %>%
kable(format = "html", escape = FALSE) %>%
kable_styling(bootstrap_options = "striped", full_width = FALSE) %>%
row_spec(0, bold = TRUE, background = "lightgreen") %>%
row_spec(10, bold = TRUE, background = "yellow") %>%
save_kable(file = "temptable.html")
browseURL("temptable.html")
我找不到根据 tableHtml 另一列中的条件设置单元格样式的方法，所以这里是另一个尝试包 gt.
一些注意事项：
gt 不包含 javascript bootstrap 代码，如 kableExtra，但 html 文件仍包含 CSS 代码。 - 我不明白你对前缀的要求，所以我忽略了。
- 我单独而不是一起考虑这些条件。
- 将所有缺失值合并为
NA 将允许 gt 处理百分号 等 ，而不是将它们作为文本包含（这使得事情比较复杂，尤其是测试条件）。
总而言之，这段代码应该很容易修改以更贴切地满足您的需求：
library(tibble)
library(gt)
library(stringr)
library(dplyr)
# data with the requested use cases :
Dataframe <-
tribble(
~seq, ~count1, ~percentage1, ~Marking, ~count2, ~Percentage2, ~batch_no, ~count3, ~Percentage3,
"FRD", 1, "12.50%", "S1", "2", "25.00%", "6", "1", "12.50%",
"FHL", 1, "12.50%", "S2", "1", "12.50%", "7", "2", "25.00%",
"ABC", 2, "25.00%", "S3", "1", "12.50%", "8", "2", "45.00%",
"ABC", 2, "25.00%", "S3", "1", "12.50%", "9", "2", "17.00%",
"DEF", 1, "12.50%", "Hold", "2", "45.00%", "9", "1", "12.50%",
"XYZ", 1, "12.50%", "NA", "1", "12.50%", "NA", "1", "12.50%",
"ZZZ", 1, "12.50%", "(Blank)", "1", "12.50%", "(Blank)", "1", "12.50%",
"FRD", 1, "12.50%", "-", "-", "-", "-", "-", "-",
"NA", 1, "12.50%", "-", "-", "-", "-", "-", "-",
"(Blank)", 0, "0.00%", "-", "-", "-", "-", "-", "-",
"Total", 8, "112.50%", "-", "8", "100.00%", "-", "8", "100.00%"
)
test1 <- expression(Marking == "Hold" & as.numeric(str_remove(Percentage2, "%")) > 25.00)
test2 <- expression(batch_no == "8" & as.numeric(str_remove(Percentage3, "%")) > 25.00)
test3 <- expression(Marking == "S3" & batch_no == "9")
newtab <-
Dataframe %>%
mutate(Marking = ifelse(eval(test3), paste0(Marking, " (In progress)"), Marking)) %>%
gt() %>%
#
tab_style(style = list(cell_fill(color = "lightgreen"),
cell_text(weight = "bold")),
locations = cells_column_labels(columns = 1:9)) %>%
#
tab_style(style = list(cell_fill(color = "yellow"),
cell_text(weight = "bold")),
locations = cells_body(columns = 1:9, rows = nrow(Dataframe)) %>%
#
tab_style(style = list(cell_fill(color = "red"),
cell_text(color = "white", weight = "bold")),
locations = cells_body(columns = c("Marking", "Percentage2"),
rows = eval(test1))) %>%
#
tab_style(style = list(cell_fill(color = "red"),
cell_text(color = "white", weight = "bold")),
locations = cells_body(columns = c("batch_no", "Percentage3"),
rows = eval(test2))) %>%
#
tab_style(style = list(cell_text(size = px(2))),
locations = cells_body(columns = c("Marking"),
rows = str_detect(string = Marking, pattern = "progress")))
gtsave(newtab, file = "gttable.html")
我不确定我是否正确理解了您的所有需求，但这是使用包 flextable 做出的回答。
library(officer)
library(flextable)
library(magrittr)
dat <- tibble::tribble(
~seq, ~count1, ~percentage1, ~Marking, ~count2, ~percentage2, ~batch_no, ~count3, ~percentage3,
"FRD", 1, "12.50%", "S1", "2", "25.00%", "6", "1", "12.50%",
"FHL", 1, "12.50%", "S2", "1", "12.50%", "7", "2", "25.00%",
"ABC", 2, "25.00%", "S3", "1", "12.50%", "8", "2", "45.00%",
"DEF", 1, "12.50%", "Hold", "2", "45.00%", "9", "1", "12.50%",
"XYZ", 1, "12.50%", "NA", "1", "12.50%", "NA", "1", "12.50%",
"ZZZ", 1, "12.50%", "(Blank)", "1", "12.50%", "(Blank)", "1", "12.50%",
"FRD", 1, "12.50%", NA_character_, NA_character_, NA_character_, NA_character_, NA_character_, NA_character_,
"NA", 1, "12.50%", NA_character_, NA_character_, NA_character_, NA_character_, NA_character_, NA_character_,
"(Blank)", 0, "0.00%", NA_character_, NA_character_, NA_character_, NA_character_, NA_character_, NA_character_,
"Total", 8, "112.50%", NA_character_, "8", "100.00%", NA_character_, "8", "100.00%"
)
dat$percentage1 <- gsub("%", "", dat$percentage1) %>% as.double()
dat$percentage2 <- gsub("%", "", dat$percentage2) %>% as.double()
dat$percentage3 <- gsub("%", "", dat$percentage3) %>% as.double()
# I need to add table header color as light green
# with bold font and last row of the table as orange
# with bold font.
flextable(dat) %>%
fontsize(size = 11, part = "all") %>%
bold(part = "header") %>%
color(color = "#90EE90", part = "header") %>%
color(color = "orange", i = ~ seq %in% "Total") %>%
bold(i = ~ seq %in% "Total") %>%
#' Also, Need to add the condition that if Percentage of Hold
#' in marking and Percentage of 8 in batch_no is >25% mark it
#' as a dark red with bold white font.
color(i = ~ percentage1 > 10 & Marking %in% "Hold",
j = c("count1", "percentage1", "Marking"),
color = "red", part = "body") %>%
color(i = ~ percentage2 > 10 & batch_no %in% "8",
j = c("count2", "percentage2", "batch_no"),
color = "red", part = "body") %>%
bold(i = ~ percentage1 > 10 & Marking %in% "Hold",
j = c("count1", "percentage1", "Marking"),) %>%
bold(i = ~ percentage2 > 10 & batch_no %in% "8",
j = c("count2", "percentage2", "batch_no")) %>%
#' If possible, can we add the suffix in S3 as S3 (In Progress)
#' and 9 as `9 (In Progress) where the font of (In Progress) will
#' be 2 font less than variable name.
#' The added text (In Progress) should be in orange font with bold.
compose(i = ~ Marking %in% "S3", j = "Marking",
value = as_paragraph(
"S3 ",
as_chunk("(In Progress)",
props = fp_text(color = "orange", bold = TRUE, font.size = 5.5))
)
) %>%
autofit()
您实际上可以完全使用您在 add_font 中所做的事情来获得您需要的 tableHTML
library(tableHTML)
library(dplyr)
Dataframe <- read.table(text='seq count percentage Marking count percentage batch_no count percentage
FRD 1 12.50% S1 2 25.00% 6 1 12.50%
FHL 1 12.50% S2 1 12.50% 7 2 25.00%
ABC 2 25.00% S3 1 12.50% 8 2 25.00%
DEF 1 12.50% Hold 2 25.00% 9 1 12.50%
XYZ 1 12.50% NA 1 12.50% NA 1 12.50%
ZZZ 1 12.50% (Blank) 1 12.50% (Blank) 1 12.50%
FRD 1 12.50% - - - - - -
NA 1 12.50% - - - - - -
(Blank) 0 0.00% - - - - - -
Total 8 112.50% - 8 100.00% - 8 100.00%',
header = TRUE, stringsAsFactors = FALSE) %>% as_tibble()
names_orig <- Dataframe %>% names()
# add numeric columns to get the conditions
Dataframe$percentage.1_num <- gsub("%", "", Dataframe$percentage) %>% as.numeric()
Dataframe$percentage.2_num <- gsub("%", "", Dataframe$percentage.1) %>% as.numeric()
add_font <- function(x) {
x <- gsub('\(', '\(<font size="-1">', x)
x <- gsub('\)', '</font>\)', x)
return(x)
}
add_style <- function(x, style){
x <- paste0('<div ', style, '>', x, '</div>')
return(x)
}
add_in_progress <- function(x){
x <- paste0(x, '<font size="1" color="red">', '(In Progress)', '</font>')
return(x)
}
# define the style you want to apply where the condition hold
style <- 'style="background-color:darkred;font-weight:bold;color:white;"'
condition_1 <- Dataframe$Marking=='Hold' & Dataframe$percentage.1_num > 10
condition_2 <- Dataframe$batch_no==8 & Dataframe$percentage.2_num > 10
Html_Table<-
Dataframe %>%
mutate(`Marking` = add_font(`Marking`),
`batch_no` = add_font(`batch_no`)) %>%
# add the style where the condition holds
mutate(percentage = ifelse(condition_1,
add_style(percentage, style),
percentage),
# Marking = ifelse(condition_1,
# add_style(Marking, style),
# Marking),
percentage.1 = ifelse(condition_2,
add_style(percentage.1, style),
percentage.1),
# batch_no = ifelse(condition_2,
# add_style(batch_no, style),
# batch_no)
) %>%
# add in progress where the condition holds
mutate(Marking = ifelse(Marking=='S3',
add_in_progress(Marking),
Marking)) %>%
mutate(batch_no = ifelse(batch_no=='9',
add_in_progress(batch_no),
batch_no)) %>%
# select the columns you want to show
select(names_orig) %>%
# give it to tableHTML, you could also set the headers you want to show
# and replace character NA with the empty string
tableHTML(rownames = FALSE,
escape = FALSE,
widths = rep(100, 9),
replace_NA = '',
headers = names_orig %>% gsub('.[1-9]', '', .),
caption = "Dataframe: Test",
border = 0) %>%
# header style
add_css_header(css = list(c('background-color', 'border-top', 'border-bottom'),
c('lightgreen', '3px solid black', '3px solid black')),
headers = 1:ncol(Dataframe)) %>%
# last row style
add_css_row(css = list(c('background-color', 'font-weight'),
c('yellow', 'bold')),
rows = nrow(Dataframe)+1)
Html_Table
我在 R 中使用以下结构化数据框。
数据框<-
seq count percentage Marking count Percentage batch_no count Percentage
FRD 1 12.50% S1 2 25.00% 6 1 12.50%
FHL 1 12.50% S2 1 12.50% 7 2 25.00%
ABC 2 25.00% S3 1 12.50% 8 2 25.00%
DEF 1 12.50% Hold 2 25.00% 9 1 12.50%
XYZ 1 12.50% NA 1 12.50% NA 1 12.50%
ZZZ 1 12.50% (Blank) 1 12.50% (Blank) 1 12.50%
FRD 1 12.50% - - - - - -
NA 1 12.50% - - - - - -
(Blank) 0 0.00% - - - - - -
Total 8 112.50% - 8 100.00% - 8 100.00%
数据框的列数是静态的，但行数可以变化。例如，某些条件下的行数可能是 15 或更少，可能是 4 或 5。
我需要添加 table header 颜色为浅绿色加粗字体，最后一行 table 颜色为黄色加粗字体。另外，需要添加条件，如果Percentage of Hold in marking and Percentage of 8 in batch_no is >25% mark it as a dark red with bold white font.
如果可能的话，我们可以在S3中添加后缀为S3 (In Progress)和9作为`9（进行中）其中（进行中）的字体将是2字体小于变量名.
添加的文字(In Progress)应为黄色加粗字体。
我正在使用下面提到的代码：
library(tableHTML)
library(dplyr)
add_font <- function(x) {
x <- gsub('\(', '\(<font size="-1">', x)
x <- gsub('\)', '</font>\)', x)
return(prettyNum(x, big.mark = ','))
}
Html_Table<-Dataframe %>%
mutate(`Marking` = add_font(`Marking`),
`batch_no` = add_font(`batch_no`)) %>%
tableHTML(rownames = FALSE,
escape = FALSE,
widths = rep(100, 12),
caption = "Dataframe: Test",
theme='scientific') %>%
add_css_caption(css = list(c("font-weight", "border","font-size"),
c("bold", "1px solid black","16px"))) %>%
add_css_row(css = list(c("background-color"), c("lightblue")), rows = 0:1)%>%
add_css_caption(css = list(c("background-color"), c("lightblue"))) %>%
add_css_row(css = list('background-color', '#f2f2f2'),
rows = odd(1:10)) %>%
add_css_row(css = list('background-color', '#e6f0ff'),
rows = even(1:10)) %>%
add_css_row(css = list(c("background-color","font-weight"), c("yellow", "bold")),
rows = even(2:3)) %>%
add_css_row(css = list(c("font-style","font-size"), c("italic","12px")),
rows = 4:8)
这是一个使用 kableExtra 而不是 htmlTable...
library(tidyverse)
library(knitr)
library(kableExtra)
Dataframe<-
tribble(
~seq, ~count1, ~percentage1, ~Marking, ~count2, ~Percentage2, ~batch_no, ~count3, ~Percentage3,
"FRD", 1, "12.50%", "S1", "2", "25.00%", "6", "1", "12.50%",
"FHL", 1, "12.50%", "S2", "1", "12.50%", "7", "2", "25.00%",
"ABC", 2, "25.00%", "S3", "1", "12.50%", "8", "2", "45.00%",
"DEF", 1, "12.50%", "Hold", "2", "45.00%", "9", "1", "12.50%",
"XYZ", 1, "12.50%", "NA", "1", "12.50%", "NA", "1", "12.50%",
"ZZZ", 1, "12.50%", "(Blank)", "1", "12.50%", "(Blank)", "1", "12.50%",
"FRD", 1, "12.50%", "-", "-", "-", "-", "-", "-",
"NA", 1, "12.50%", "-", "-", "-", "-", "-", "-",
"(Blank)", 0, "0.00%", "-", "-", "-", "-", "-", "-",
"Total", 8, "112.50%", "-", "8", "100.00%", "-", "8", "100.00%"
)
test1 <- expression(Marking == "Hold" & as.numeric(str_remove(Percentage2, "%")) > 25.00)
test2 <- expression(batch_no == "8" & as.numeric(str_remove(Percentage3, "%")) > 25.00)
Dataframe %>%
mutate(Percentage2 = cell_spec(Percentage2,
"html",
background = ifelse(eval(test1), "red", ""),
color = ifelse(eval(test1), "white", "black")),
Percentage3 = cell_spec(Percentage3,
"html",
background = ifelse(eval(test2), "red", ""),
color = ifelse(eval(test2), "white", "black"))) %>%
kable(format = "html", escape = FALSE) %>%
kable_styling(bootstrap_options = "striped", full_width = FALSE) %>%
row_spec(0, bold = TRUE, background = "lightgreen") %>%
row_spec(10, bold = TRUE, background = "yellow") %>%
save_kable(file = "temptable.html")
browseURL("temptable.html")
我找不到根据 tableHtml 另一列中的条件设置单元格样式的方法，所以这里是另一个尝试包 gt.
一些注意事项：
gt不包含 javascript bootstrap 代码，如kableExtra，但 html 文件仍包含 CSS 代码。- 我不明白你对前缀的要求，所以我忽略了。
- 我单独而不是一起考虑这些条件。
- 将所有缺失值合并为
NA将允许gt处理百分号 等 ，而不是将它们作为文本包含（这使得事情比较复杂，尤其是测试条件）。
总而言之，这段代码应该很容易修改以更贴切地满足您的需求：
library(tibble)
library(gt)
library(stringr)
library(dplyr)
# data with the requested use cases :
Dataframe <-
tribble(
~seq, ~count1, ~percentage1, ~Marking, ~count2, ~Percentage2, ~batch_no, ~count3, ~Percentage3,
"FRD", 1, "12.50%", "S1", "2", "25.00%", "6", "1", "12.50%",
"FHL", 1, "12.50%", "S2", "1", "12.50%", "7", "2", "25.00%",
"ABC", 2, "25.00%", "S3", "1", "12.50%", "8", "2", "45.00%",
"ABC", 2, "25.00%", "S3", "1", "12.50%", "9", "2", "17.00%",
"DEF", 1, "12.50%", "Hold", "2", "45.00%", "9", "1", "12.50%",
"XYZ", 1, "12.50%", "NA", "1", "12.50%", "NA", "1", "12.50%",
"ZZZ", 1, "12.50%", "(Blank)", "1", "12.50%", "(Blank)", "1", "12.50%",
"FRD", 1, "12.50%", "-", "-", "-", "-", "-", "-",
"NA", 1, "12.50%", "-", "-", "-", "-", "-", "-",
"(Blank)", 0, "0.00%", "-", "-", "-", "-", "-", "-",
"Total", 8, "112.50%", "-", "8", "100.00%", "-", "8", "100.00%"
)
test1 <- expression(Marking == "Hold" & as.numeric(str_remove(Percentage2, "%")) > 25.00)
test2 <- expression(batch_no == "8" & as.numeric(str_remove(Percentage3, "%")) > 25.00)
test3 <- expression(Marking == "S3" & batch_no == "9")
newtab <-
Dataframe %>%
mutate(Marking = ifelse(eval(test3), paste0(Marking, " (In progress)"), Marking)) %>%
gt() %>%
#
tab_style(style = list(cell_fill(color = "lightgreen"),
cell_text(weight = "bold")),
locations = cells_column_labels(columns = 1:9)) %>%
#
tab_style(style = list(cell_fill(color = "yellow"),
cell_text(weight = "bold")),
locations = cells_body(columns = 1:9, rows = nrow(Dataframe)) %>%
#
tab_style(style = list(cell_fill(color = "red"),
cell_text(color = "white", weight = "bold")),
locations = cells_body(columns = c("Marking", "Percentage2"),
rows = eval(test1))) %>%
#
tab_style(style = list(cell_fill(color = "red"),
cell_text(color = "white", weight = "bold")),
locations = cells_body(columns = c("batch_no", "Percentage3"),
rows = eval(test2))) %>%
#
tab_style(style = list(cell_text(size = px(2))),
locations = cells_body(columns = c("Marking"),
rows = str_detect(string = Marking, pattern = "progress")))
gtsave(newtab, file = "gttable.html")
我不确定我是否正确理解了您的所有需求，但这是使用包 flextable 做出的回答。
library(officer)
library(flextable)
library(magrittr)
dat <- tibble::tribble(
~seq, ~count1, ~percentage1, ~Marking, ~count2, ~percentage2, ~batch_no, ~count3, ~percentage3,
"FRD", 1, "12.50%", "S1", "2", "25.00%", "6", "1", "12.50%",
"FHL", 1, "12.50%", "S2", "1", "12.50%", "7", "2", "25.00%",
"ABC", 2, "25.00%", "S3", "1", "12.50%", "8", "2", "45.00%",
"DEF", 1, "12.50%", "Hold", "2", "45.00%", "9", "1", "12.50%",
"XYZ", 1, "12.50%", "NA", "1", "12.50%", "NA", "1", "12.50%",
"ZZZ", 1, "12.50%", "(Blank)", "1", "12.50%", "(Blank)", "1", "12.50%",
"FRD", 1, "12.50%", NA_character_, NA_character_, NA_character_, NA_character_, NA_character_, NA_character_,
"NA", 1, "12.50%", NA_character_, NA_character_, NA_character_, NA_character_, NA_character_, NA_character_,
"(Blank)", 0, "0.00%", NA_character_, NA_character_, NA_character_, NA_character_, NA_character_, NA_character_,
"Total", 8, "112.50%", NA_character_, "8", "100.00%", NA_character_, "8", "100.00%"
)
dat$percentage1 <- gsub("%", "", dat$percentage1) %>% as.double()
dat$percentage2 <- gsub("%", "", dat$percentage2) %>% as.double()
dat$percentage3 <- gsub("%", "", dat$percentage3) %>% as.double()
# I need to add table header color as light green
# with bold font and last row of the table as orange
# with bold font.
flextable(dat) %>%
fontsize(size = 11, part = "all") %>%
bold(part = "header") %>%
color(color = "#90EE90", part = "header") %>%
color(color = "orange", i = ~ seq %in% "Total") %>%
bold(i = ~ seq %in% "Total") %>%
#' Also, Need to add the condition that if Percentage of Hold
#' in marking and Percentage of 8 in batch_no is >25% mark it
#' as a dark red with bold white font.
color(i = ~ percentage1 > 10 & Marking %in% "Hold",
j = c("count1", "percentage1", "Marking"),
color = "red", part = "body") %>%
color(i = ~ percentage2 > 10 & batch_no %in% "8",
j = c("count2", "percentage2", "batch_no"),
color = "red", part = "body") %>%
bold(i = ~ percentage1 > 10 & Marking %in% "Hold",
j = c("count1", "percentage1", "Marking"),) %>%
bold(i = ~ percentage2 > 10 & batch_no %in% "8",
j = c("count2", "percentage2", "batch_no")) %>%
#' If possible, can we add the suffix in S3 as S3 (In Progress)
#' and 9 as `9 (In Progress) where the font of (In Progress) will
#' be 2 font less than variable name.
#' The added text (In Progress) should be in orange font with bold.
compose(i = ~ Marking %in% "S3", j = "Marking",
value = as_paragraph(
"S3 ",
as_chunk("(In Progress)",
props = fp_text(color = "orange", bold = TRUE, font.size = 5.5))
)
) %>%
autofit()
您实际上可以完全使用您在 add_font 中所做的事情来获得您需要的 tableHTML
library(tableHTML)
library(dplyr)
Dataframe <- read.table(text='seq count percentage Marking count percentage batch_no count percentage
FRD 1 12.50% S1 2 25.00% 6 1 12.50%
FHL 1 12.50% S2 1 12.50% 7 2 25.00%
ABC 2 25.00% S3 1 12.50% 8 2 25.00%
DEF 1 12.50% Hold 2 25.00% 9 1 12.50%
XYZ 1 12.50% NA 1 12.50% NA 1 12.50%
ZZZ 1 12.50% (Blank) 1 12.50% (Blank) 1 12.50%
FRD 1 12.50% - - - - - -
NA 1 12.50% - - - - - -
(Blank) 0 0.00% - - - - - -
Total 8 112.50% - 8 100.00% - 8 100.00%',
header = TRUE, stringsAsFactors = FALSE) %>% as_tibble()
names_orig <- Dataframe %>% names()
# add numeric columns to get the conditions
Dataframe$percentage.1_num <- gsub("%", "", Dataframe$percentage) %>% as.numeric()
Dataframe$percentage.2_num <- gsub("%", "", Dataframe$percentage.1) %>% as.numeric()
add_font <- function(x) {
x <- gsub('\(', '\(<font size="-1">', x)
x <- gsub('\)', '</font>\)', x)
return(x)
}
add_style <- function(x, style){
x <- paste0('<div ', style, '>', x, '</div>')
return(x)
}
add_in_progress <- function(x){
x <- paste0(x, '<font size="1" color="red">', '(In Progress)', '</font>')
return(x)
}
# define the style you want to apply where the condition hold
style <- 'style="background-color:darkred;font-weight:bold;color:white;"'
condition_1 <- Dataframe$Marking=='Hold' & Dataframe$percentage.1_num > 10
condition_2 <- Dataframe$batch_no==8 & Dataframe$percentage.2_num > 10
Html_Table<-
Dataframe %>%
mutate(`Marking` = add_font(`Marking`),
`batch_no` = add_font(`batch_no`)) %>%
# add the style where the condition holds
mutate(percentage = ifelse(condition_1,
add_style(percentage, style),
percentage),
# Marking = ifelse(condition_1,
# add_style(Marking, style),
# Marking),
percentage.1 = ifelse(condition_2,
add_style(percentage.1, style),
percentage.1),
# batch_no = ifelse(condition_2,
# add_style(batch_no, style),
# batch_no)
) %>%
# add in progress where the condition holds
mutate(Marking = ifelse(Marking=='S3',
add_in_progress(Marking),
Marking)) %>%
mutate(batch_no = ifelse(batch_no=='9',
add_in_progress(batch_no),
batch_no)) %>%
# select the columns you want to show
select(names_orig) %>%
# give it to tableHTML, you could also set the headers you want to show
# and replace character NA with the empty string
tableHTML(rownames = FALSE,
escape = FALSE,
widths = rep(100, 9),
replace_NA = '',
headers = names_orig %>% gsub('.[1-9]', '', .),
caption = "Dataframe: Test",
border = 0) %>%
# header style
add_css_header(css = list(c('background-color', 'border-top', 'border-bottom'),
c('lightgreen', '3px solid black', '3px solid black')),
headers = 1:ncol(Dataframe)) %>%
# last row style
add_css_row(css = list(c('background-color', 'font-weight'),
c('yellow', 'bold')),
rows = nrow(Dataframe)+1)
Html_Table