CODEWITHSUNDEEP
cssrdataframehtml-tablekableextra
Sophia Wilson
Sophia Wilson

Reputation: 477

How to create dynamic HTML table in R

I am using the following structured dataframe in R.

Dataframe<-

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%

The dataframe have number of columns static but number of rows can be vary from. For Example with some condition number of rows might be 15 or less may be 4 or 5.

I need to add table header color as light green with bold font and last row of the table as yellow with bold font. 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.

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 yellow font with bold.

I'm Using the below mentioned code:

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)

Upvotes: 5

Views: 1571

Answers (4)

DS_UNI
DS_UNI

Reputation: 2650

You can actually use exactly what you did with add_font to get what you need with 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

enter image description here

Upvotes: 1

David Gohel
David Gohel

Reputation: 10650

I am not sure I understood correctly all your needs but here is an answer made with package 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()

enter image description here

Upvotes: 1

meriops
meriops

Reputation: 1037

I can't find a way to style cells based on a condition in another column with tableHtml, so here's another attempt with package gt.

A few cautionary notes:

  • gt does not include javascript bootstrap code, as kableExtra, but the html file still includes the CSS code.
  • I don't understand your request with the prefix, so I ignored that.
  • I considered the conditions separately rather than together.
  • Consolidating all missing values to NA would allow gt to deal with the percent signs etc., rather than including them as text (which makes things more complicated, especially for testing the conditions).

All in all, this code should be easily modifiable to suit your needs more closely :

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

Upvotes: 0

meriops
meriops

Reputation: 1037

Here's a solution using kableExtra rather than 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")

Upvotes: 0

Related Questions