Как создать динамическую c HTML таблицу в R

Question

Я использую следующий структурированный фрейм данных в R.

Фрейм данных <- </p>

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%

Фрейм данных имеет количество столбцов stati c, но количество строк может отличаться от. Например, с некоторыми условиями число строк может быть 15 или меньше, может быть 4 или 5.

Мне нужно добавить цвет заголовка таблицы как светло-зеленый с жирным шрифтом, а последнюю строку таблицы как желтый с жирным шрифтом. Кроме того, необходимо добавить условие, что если Percentage из Hold в маркировке и Percentage из 8 в 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)

Answer 1

Вы можете фактически использовать то, что вы сделали с add_font, чтобы получить то, что вам нужно с таблицей HTML

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

Answer 2

Я не уверен, что правильно понял все ваши потребности, но вот ответ с пакетом 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()

Answer 3

Я не могу найти способ стилизации ячеек на основе условия в другом столбце с tableHtml, поэтому вот еще одна попытка с пакетом gt.

Несколько предостерегающих замечаний:

• gt не включает код javascript bootstrap, как kableExtra, но файл html по-прежнему содержит код CSS.
• Я не понимаю вашего запрос с префиксом, поэтому я проигнорировал это.
• Я рассмотрел условия отдельно , а не вместе.
• Консолидация всех пропущенных значений в NA позволит gt иметь дело со знаками процента et c. , а не включать их в виде текста (что усложняет задачу, особенно для проверки условий).

В целом , этот код должен быть легко модифицируемым для более точного соответствия вашим потребностям:

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")

Answer 4

Вот решение, использующее 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")