In geneorama/geneorama: Gene's collection of miscellaneous functions

library(formattable)

demo 1

mpg is red if the value is greater than 80%-quantile
am is displayed as yes or no
gear is bold when the value is 4
qsec is colorized by its value in red (higher value is redder)

formattable(mtcars, list(
  mpg = formatter("span", style = function(x)
    style(color = ifelse(x > quantile(x, 0.8), "red", NA))),
  am = formatter("span", function(x) ifelse(x == 1, "yes", "no")),
  gear = formatter("span", style = function(x)
    style(font.weight = ifelse(x == 4, "bold", NA))),
  qsec = formatter("span", style = function(x, m = qrank(x))
    style(color = rgb(m, 0, 0)))))

demo 2

conc and uptake has colorized background

data(CO2)
formattable(CO2, list(
  conc = formatter("span", style = function(x, m = 1 - x/max(x) * 0.8, ms = round(1-m)) 
    style(display = "block", border.radius = "4px", background.color = rgb(0, m, 0),
      padding.right = "4px", color = rgb(1,1,1))),
  uptake = formatter("span", style = function(x, m = 1-x/max(x), ms = round(1-m))
    style(display = "block", border.radius = "4px", padding.right = "4px",
      background.color = rgb(m, m, 0), color = rgb(ms,ms,ms)))))

demo 3

df <- data.frame(
  id = 1:10,
  name = c("Bob", "Ashley", "James", "David", "Jenny", 
    "Hans", "Leo", "John", "Emily", "Lee"), 
  age = c(28, 27, 30, 28, 29, 29, 27, 27, 31, 30),
  grade = c("C", "A", "A", "C", "B", "B", "B", "A", "C", "C"),
  test1_score = c(8.9, 9.5, 9.6, 8.9, 9.1, 9.3, 9.3, 9.9, 8.5, 8.6),
  test2_score = c(9.1, 9.1, 9.2, 9.1, 8.9, 8.5, 9.2, 9.3, 9.1, 8.8),
  final_score = c(9, 9.3, 9.4, 9, 9, 8.9, 9.25, 9.6, 8.8, 8.7),
  registered = c(TRUE, FALSE, TRUE, FALSE, TRUE, TRUE, TRUE, FALSE, FALSE, FALSE),
  stringsAsFactors = FALSE)

score_colorizer <- formatter("span", 
  style = function(x) style(
    display = "block", 
    color = "white", 
    border.radius = "4px",
    padding.right = "4px",
    background = rgb(0.2 + 0.8 * qrank(-x), 0.6, 0)))

formattable(df, list(
  grade = formatter("span",
    style = function(x) 
      ifelse(x == "A", style(
        color = "green", 
        font.weight = "bold"), NA)),
  test1_score = score_colorizer,
  test2_score = score_colorizer,
  final_score = formatter("span",
    style = function(x) style(
      color = ifelse(rank(-x) <= 3, "green", "gray")),
    function(x) sprintf("%.2f (rank: %02d)", x, rank(-x))),
  registered = function(x) ifelse(x, "yes", "no")
))

demo 4

formattable(df, list(
  # bootstrap glyphicons
  grade = formatter("span", 
    style = x ~ style(color = vmap(x, A="darkgreen",B="orange",C="darkred")), 
    x ~ icontext(vmap(x, A="star",B="ok",C="remove"), x)),
  # bar
  test1_score = formatter("span", 
    style = x ~ style(color = "white", 
                      background = "green", 
                      padding.left = sprintf("%.0fpx", 4 + 76 * normalize(x)),
                      padding.right = "4px",
                      border.radius = "4px")),
  # bar
  test2_score = formatter("span", 
    style = x ~ style(color = "white", 
                      background = "green", 
                      padding.right = sprintf("%.0fpx", 4 + 76 * normalize(x)),
                      padding.left = "4px",
                      border.radius = "4px")),
  # gradient
  final_score = formatter("span", 
    style = x ~ style(display = "block",
      background = rgb(0.3, 0, 1 - 0.8 * qrank(x)),
      color = "white", padding.right = "5px", border.radius = "4px")),
  # text transform
  registered = x ~ ifelse(x, "yes", "no")),
  align = c("r","l","r","c","r","l","r","c"))

demo 5

formattable(df, list(
  grade = formatter("span",
    style = x ~ vmap(x, A = style(color = "green", font.weight = "bold"), NA)),
  test1_score = formatter("span",
    style = x ~ style(color = csscolor(gradient(rank(x), "black", "red")))),
  test2_score = formatter("span",
    style = x ~ style(color = csscolor(gradient(rank(x), "black", "red")))),
  final_score = formatter("span",
    style = x ~ style(color = ifelse(rank(-x) <= 3, "green", "gray"))),
  registered = x ~ ifelse(x, "yes", "no")
))