Expanding color_tile to 2+ colours

[Victor-GY-Yu]

Hi,

I asked this question on stack, where I was looking to achieve the usage of color_tile rowwise, and the answer provided which works great.

library(tidyverse)
library(knitr)
library(kableExtra)
library(formattable)

set.seed(1)
df <- data.frame(letters = letters[1:5],
                 foo = rnorm(5, 20),
                 bar = c(2, 7, 10, 15, 30),
                 baz = rnorm(5, 20),
                 bash = rnorm(5, 20),
                 stringsAsFactors = FALSE)

for(i in 1:nrow(df)) df[i,] <- color_tile("pink", "lightblue")(df[i,])

df %>%
    kable(escape = F) %>%
    kable_styling("hover", full_width = F) %>%
    column_spec(5, width = "3cm") %>%
    add_header_above(c(" ", "Hello" = 2, "World" = 2))

However, what I would like to do now is to expand the use of color_tile towards 3 colours, in a traffic colour gradient (red-yellow-green). Here, the solution isn't very effective if I use "red" and "green" as parameters to color_tile as the central colour is brown.

I tried adapting this answer, however the manner I am using color_tile is different than the one in the question, as I'm implementing the function row-wise in a loop.. and I get numerous errors.

Was wondering if you guys would know of a work-around - it would be greatly appreciated.

[monkeywithacupcake]

you can use the concept of color tile and write your own function, like this

stoplighttile <- function(cut1 = .1, cut2 = .2, fun = "comma", digits = 0) {
  fun <- match.fun(fun)
  formatter("span", x ~ fun(x, digits = digits),
            style = function(y) style(
              display = "block",
              padding = "0 4px",
              "border-radius" = "4px",
              "color" = ifelse( y >= cut2, csscolor("#FFFDF9"), csscolor("black")),
              "background-color" = ifelse( y < cut1, csscolor("#50D890"),
                                          ifelse( y < cut2, csscolor("#F6DA63"),
                                                 csscolor("#E32249")))
            )
  )
}

Then, you call it just like you would call color tile, in the table call. Here's an example from a recent table that I had.

formattable(df, 
            list(area(col = 3:ncol(df)) ~ stoplighttile(cut1 = 0.1, cut2 = 0.5, fun = "percent", digits = 0))
              )

Note - this is a manual-ish work around. You could alternately use the scales package to generate a scale for colors and not have to set the cut points manually.

[cmilando]

Something like this might work, leveraging RColorBrewer

color_tile3 <- function(fun = "comma", digits = 0, palette = 'RdBu', n = 9) {
  fun <- match.fun(fun)

  stopifnot(n >= 5)
  
  return_cut <- function(y) 
    cut(y, breaks = quantile(y, probs = 0:n/n, na.rm = T),
        labels = 1:n, ordered_result = T, include.lowest = T)
  
  return_col <- function(y) 
      RColorBrewer::brewer.pal(n, palette)[as.integer(return_cut(y))]
  
  formatter("span", x ~ fun(x, digits = digits),
            style = function(y) style(
              display = "block",
              padding = "0 4px",
              "border-radius" = "4px",
              "color" = ifelse( return_cut(y) %in% c(1, 2, n-1, n),
                                csscolor("white"), csscolor("black")),
              "background-color" = return_col(y)
            )
  )
}

Example

library(tidyverse)
library(RColorBrewer)

mtcars[, 1:5] %>%
  corrr::correlate() %>%
  formattable(., list(
    `rowname` = formatter("span", style = ~ style(color = "grey", 
                                                  font.weight = "bold")), 
    area(col = 2:6) ~ color_tile3(digits = 2)))