R flextable conditional formatting based on pairs of rows

Question

I am trying to change the bg color of some cells in a flextable based on whether the values in the rows labeled Act (for actual) exceed the values in the corresponding rows (that is, same KPI ) labeled Plan . Those that exceed should get a green background, while those values that are below Plan should get a red background.

(In a perfect world, I would be able to change the background color whether the cell was greater than or less than, depending upon a list I configured to say which direction to go, but that will come next.)

df <- structure(list(KPI = c("Quality", "Quality", "On Time", "On Time", 
"Attrition", "Attrition", "Growth 1", "Growth 1", "Growth 2", 
"Growth 2", "WCT", "WCT", "ROI", "ROI"), Type = c("Plan", "Act", 
"Plan", "Act", "Plan", "Act", "Plan", "Act", "Plan", "Act", "Plan", 
"Act", "Plan", "Act"), JAN = c(1, 1, NA, NA, 0.05, 0.09, NA, 
NA, NA, NA, 4, -1.8, NA, NA), FEB = c(1, 0.98, NA, NA, 0.05, 
0.08, NA, NA, NA, NA, -0.2, -1.3, NA, NA), MAR = c(1, 1, 0.79, 
0.81, 0.05, 0.08, 0.1, 0.08, 116, 199, -0.7, -0.2, NA, NA), APR = c(1, 
1, NA, NA, 0.05, 0.08, NA, NA, NA, NA, -0.2, -0.3, NA, NA), MAY = c(1, 
1, NA, NA, 0.05, 0.09, NA, NA, NA, NA, -0.2, -0.6, NA, NA), JUN = c(1, 
1, 0.79, 0.8, 0.05, 0.08, 0.12, 0.03, -33, 22, 0.1, 1.1, NA, 
NA), JUL = c(1, 1, NA, NA, 0.05, 0.09, NA, NA, NA, NA, 0.3, 0.2, 
NA, NA), AUG = c(1, 1, NA, NA, 0.05, 0.09, NA, NA, NA, NA, 0.3, 
0.8, NA, NA), SEP = c(1, 1, 0.79, 0.78, 0.05, 0.09, 0.2, 0.14, 
173, 303, 1.5, 2.1, NA, NA), OCT = c(1, NA, NA, NA, 0.05, NA, 
NA, NA, NA, NA, 2.3, NA, NA, NA), NOV = c(1, NA, NA, NA, 0.05, 
NA, NA, NA, NA, NA, 2, NA, NA, NA), DEC = c(1, NA, NA, NA, 0.05, 
NA, NA, NA, NA, NA, 0.2, NA, NA, NA)), row.names = c(NA, -14L
), class = c("tbl_df", "tbl", "data.frame"))

library(regulartable)
library(magrittr)

df %>% regulartable() %>% bg(i = ~ Type %in% "Act", j = 3:14, bg="#cceecc")

The image it produces is below. I am currently stuck because I can not figure out how to add a second condition, that is, whatever would go in the (value > lag(value)) position. Does anyone know, or do I need to spread and gather first? Any help would be greatly appreciated.

df %>% regulartable() %>% bg(i = ~ Type %in% "Act" && (value > lag(value)), j = 3:14, bg="#cceecc")

Answer 1

I'm sure there is a more elegant way to solve this, and if there is, I hope someone posts it. But in the meantime I found a stopgap. First split the df into plan values and actual values, and then use those differences to determine appropriate color for each cell:

library(gdata)

df %>% group_split(Type) -> plan.act
ifelse(plan.act[[1]][,3:14]-plan.act[[2]][,3:14]>=0, "#cceecc", "#eecccc") -> colorgrid 

This creates a list of red/green colors for each cell:

> colorgrid
     JAN       FEB       MAR       APR       MAY       JUN       JUL       AUG       SEP       OCT NOV DEC
[1,] "#cceecc" "#eecccc" "#cceecc" "#cceecc" "#cceecc" "#cceecc" "#cceecc" "#cceecc" "#cceecc" NA  NA  NA 
[2,] NA        NA        "#cceecc" NA        NA        "#cceecc" NA        NA        "#eecccc" NA  NA  NA 
[3,] "#cceecc" "#cceecc" "#cceecc" "#cceecc" "#cceecc" "#cceecc" "#cceecc" "#cceecc" "#cceecc" NA  NA  NA 
[4,] NA        NA        "#eecccc" NA        NA        "#eecccc" NA        NA        "#eecccc" NA  NA  NA 
[5,] NA        NA        "#cceecc" NA        NA        "#cceecc" NA        NA        "#cceecc" NA  NA  NA 
[6,] "#eecccc" "#eecccc" "#cceecc" "#eecccc" "#eecccc" "#cceecc" "#eecccc" "#cceecc" "#cceecc" NA  NA  NA 
[7,] NA        NA        NA        NA        NA        NA        NA        NA        NA        NA  NA  NA 

Now create another df for colors for the Plan group, then plot the table:

blankgrid <- colorgrid
blankgrid[!is.na(blankgrid)] <- NA_character_

df %>% regulartable() %>% bg(j = 3:14, bg=interleave(blankgrid,colorgrid))

And from there you can add more flextable goodness to make table prettier:

df %>% regulartable() %>% bg(j = 3:14, bg=interleave(blankgrid,colorgrid)) %>%
     merge_v(j=1) %>% border_inner_v(border = fp_border(color="gray", width=1))