Rで動的HTMLテーブルを作成する方法
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かもしれません。
テーブルヘッダーの色をボールドフォントのライトグリーンとして追加し、テーブルの最後の行をボールドフォントの黄色として追加する必要があります。また、Percentage of Hold in markおよびPercentage of 8 in batch_noが> 25％の場合、それを濃い赤として太字の白いフォントでマークするという条件を追加する必要があります。
可能であれば、_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)
_実際に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
私はあなたのすべてのニーズを正しく理解したかどうかはわかりませんが、パッケージ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()
これは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にはkableExtraのようにjavascript bootstrapコードが含まれていませんが、htmlファイルにはCSSコードが含まれています。- プレフィックス付きのリクエストを理解できなかったため、無視しました。
- 一緒にではなく、条件個別にを検討しました。
- すべての欠損値を
NAに統合すると、gtがパーセント記号etc。を処理できるようになり、テキストとして含めるのではなく（特に、条件のテスト）。
全体として、このコードは、ニーズに合わせて簡単に変更できるはずです。
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")