Conditionally fill cells in specific columns with colour based on value in another column

Question

I have the following data frame:

col1 <- rep(c("A","B","C","D"),10)
col2 <- rep(c(1,0),10)
col3 <- rep(c(0,1),10)
col4 <- rep(c(1,0),10)
col5 <- rep(c(0,1),10)

test_df <- data.frame(col1, col2, col3, col4, col5, stringsAsFactors = F)

I would like to color specific row cells across multiple columns based on the values in col1, and also add a vertical line (indicating a limit) between two columns in the table (based on the same value in col1)

For example, if col1 == "A", then i want to color the cells in col2 and col5 grey, in the same row as col1 == A.

In dummy code:

if col1 == A: color columns(col2, col5), vert.line between col3 and col4
if col1 == B: color columns(col2, col3, col5), vert.line between col4 and col5
if col1 == C: color columns(col2, col4, col5), vert.line between col3 and col4
if col1 == D: color columns(col2, col5), vert.line between col2 and col3

I would like to specify these rules so they can easily be changed if necessary.

I want to end up with something like this (asterisks indicate cell coloring):

col1   col2   col3   col4   col5
A      *1*     0   | 1      *0*
B      *0*    *1*    0    | *1*
C      *1*    *0*  | 1      *0*
D      *0*  |  1     0      *1*
A      *1*     0   | 1      *0*
B      *0*    *1*    0    | *1*
C      *1*    *0*  | 1      *0*
D      *0*  |  1     0      *1*

I am presenting this in a table in a shiny app and markdown document. Is there any way to do this with f. ex xtable or dplyr?

Answer 1

There is a solution using tableHTML in combination with 2 functions to replicate the logic.

First, you need to create css for each column that provides the styling information that should be applied to the table. I have split it into 2 functions, one for the background, and one for the line between columns.

library(tableHTML)

The first function changes the colour of cells based on the value in col1. You can change them by providing different colours in the arguments of the function.

get_background_column_css <- function(col1,
                                   a_col = "lightgray",
                                   b_col = "steelblue",
                                   c_col = "lightgreen",
                                   d_col = "indianred",
                                   default = "white") {
  # create css for col2
  background_color_col2 <- ifelse(col1 == "A", a_col, 
                      ifelse(col1 == "B", b_col,
                      ifelse(col1 == "C", c_col,
                      ifelse(col1 == "D", d_col, default
                             ))))
  css_col2 <- setNames(list(list(c("background-color"),
                     list(background_color_col2))), "col2")

  # create css for col3
  background_color_col3 <- ifelse(col1 == "B", b_col,
                                  ifelse(col1 == "C", c_col, default))
  css_col3 <- setNames(list(list(c("background-color"),
                                 list(background_color_col3))), "col3")
  # create css for col4
  background_color_col4 <- rep("", length(col1))
  css_col4 <- setNames(list(list(c("background-color"),
                                 list(background_color_col4))), "col4")
  # create css for col5
  background_color_col5 <- ifelse(col1 == "A", a_col, 
                                  ifelse(col1 == "B", b_col,
                                         ifelse(col1 == "C", c_col,
                                                ifelse(col1 == "D", d_col, default
                                                ))))
  css_col5 <- setNames(list(list(c("background-color"),
                                 list(background_color_col5))), "col5")

  list(css_col2, css_col3, css_col4, css_col5)
}

The second function adds a border between columns.

get_border_column_css <- function(col1) {
  # create css for col2
  border_col2 <- ifelse(col1 == "D", "1px solid black", "0px")
  css_col2 <- setNames(list(list(c("border-right"),
                                 list(border_col2))), "col2")
  # create css for col3
  border_col3 <- ifelse(col1 == "C", "1px solid black", "0px")
  css_col3 <- setNames(list(list(c("border-right"),
                                 list(border_col3))), "col3")
  # create css for col4
  border_col4 <- ifelse(col1 == "B", "1px solid black", "0px")
  css_col4 <- setNames(list(list(c("border-right"),
                                 list(border_col4))), "col4")
  # create css for col5
  border_col5 <- rep("0px", length(col1))
  css_col5 <- setNames(list(list(c("border-right"),
                                 list(border_col5))), "col5")

  list(css_col2, css_col3, css_col4, css_col5)
}

In order to test the function, I only use the first 4 rows (since they have all the combinations of possibilities):

test_df <- head(test_df, 4)

Next, I create 1 css list for the background-color and 1 css list for the border that can be supplied to add_css_conditional_column()

css_background = get_background_column_css(test_df$col1)
css_border = get_border_column_css(test_df$col1)

Next, I create a tableHTML object.

tableHTML <- tableHTML(test_df,
                       rownames = FALSE,
                       border = 0) 

Next, I add the background css in a loop to each column:

for (i in 1:4) {
  tableHTML <- tableHTML %>%
    add_css_conditional_column(conditional = "colour_rank",
                               colour_rank_css = css_background[[i]],
                               columns = names(test_df)[i + 1])
}

And the border css:

for (i in 1:4) {
  tableHTML <- tableHTML %>%
    add_css_conditional_column(conditional = "colour_rank",
                               colour_rank_css = css_border[[i]],
                               columns = names(test_df)[i + 1])
}

This is the result:

tableHTML

Answer 2

Here is a partial (doesn't do the custom line separation between columns) solution.

For the following, I leverage the package formattable.

The dataframe used is df as defined in your question.

library(formattable)
library(dplyr)

## Function that create the formula for the coloring of each row
## You could also personalize the color
color_row <- function(r,
                      c,
                      color = 'gray') {

  return(area(row = r, col = c) ~ color_tile(color, color))
}

## Create database that containes info on coloring pattern
df_color <- data_frame(col1 = c('A', 'B', 'C', 'D'),
                       limits = list(c(2,5), c(2,3,5), c(2,4,5), c(2,5)))


## Join it to original data.frame
df_join <- df %>% left_join(df_color) 

## Create list with all the appropriate formulas to color data frame
format_list <- mapply(color_row, r = 1:nrow(df), c = df_join$limits, color = 'gray')

## Pass it to formattable
df_final <- formattable(df,format_list) 

The result looks like this:

This can be easily used in RNotebook and Shiny. Following example codes for each (for the code below to work, you need the result of the previous code df_final to be in your environment):

---
title: "R Notebook"
output: html_notebook
---

```{r}
library(dplyr)
library(formattable)
format_table(df_final)
```

Shiny:

library(shiny)
library(formattable)
  # table example
  shinyApp(
    ui = fluidPage(
      fluidRow(
        column(12,
               formattableOutput('table')
        )
      )
    ),

    server = function(input, output) {


      output$table <- renderFormattable(df_final)
    }
  )