I'm trying to apply conditional formatting based on data within a row. I've tried a number of libraries including DT, Reactablefmtr and formatter. The idea is to put it into shiny to present table of findings.
How do I make this function more dynamic to not call it for each row but reference it to the norm variable?
# the table
fin_ratios <- data.frame(
descr = c("Ratio 1", "Ratio 2"),
norm = c(10, 20),
`2021` = c(11, 19),
`2022` = c(9, 21)
)
The code to style the table:
library(formattable)
custom_color_tile <- function (x, x_norm = 10) {
formatter("span",
style = x ~ style(display = "block",
padding = "0 4px",
`color` = "white",
`border-radius` = "4px",
`background-color` = ifelse(x >= x_norm, "green", "red")))
}
fin_ratios %>%
formattable(
list(
area(col = 3:4, row = 1) ~ custom_color_tile(x_norm = 10),
area(col = 3:4, row = 2) ~ custom_color_tile(x_norm = 20)
)
)
Your function is already working. Instead of using single values for x_norm, you can use the norm variable as a vector fin_ratios$norm.
formattable(fin_ratios,
list(area(col = 3:4) ~ custom_color_tile(x_norm = fin_ratios$norm)))
You may just pay attention, if you want to color certain rows. Than you have to select the rows of the norm variable as well.
# color just first row
formattable(fin_ratios,
list(area(col = 3:4,
row = 1) ~ custom_color_tile(x_norm = fin_ratios$norm[1])))
Related
Aim
Giving a different color to a table's cells according to numerical threshold(s).
R Package
gt
Reproducible example
mydata <- structure(list(none = c(4, 4, 25, 18, 10), light = c(2, 3, 10,
24, 6), medium = c(3, 7, 12, 33, 7), heavy = c(2, 4, 4, 13, 2
)), row.names = c("SM", "JM", "SE", "JE", "SC"), class = "data.frame")
Using the above dataset, I can produce a table (however crude), using the following code:
mytable <- gt::gt(mydata)
Where I got stuck
It must be really easy, but I can wrap my head around how to assign (say) red to the cells where the value is (say) larger than 20 AND blue to cells whose value is (say) smaller than 10. It's days now that I am trying to do a little of google search (example HERE), but I could not find a solution. It must be pretty simple but no success so far. My best guess is using the tab_style() function, but I am at loss of understanding how to tune the parameters to get what I am after.
This isn't ideal if you have an arbitrarily large data frame, but for an example of your size it's certainly manageable, imo. I generalized the tests as separate functions to reduce additional code duplication and make it easier to adjust your conditional parameters.
If you're looking for a more generalized solution it would be to look over a vector of columns, as described here.
library(gt)
isHigh <- function(x) {
x > 20
}
isLow <- function(x) {
x < 10
}
mydata %>%
gt() %>%
tab_style(
style = list(
cell_fill(color = 'red'),
cell_text(weight = 'bold')
),
locations =
list(
cells_body(
columns = none,
rows = isHigh(none)
),
cells_body(
columns = light,
rows = isHigh(light)
),
cells_body(
columns = medium,
rows = isHigh(medium)
),
cells_body(
columns = heavy,
rows = isHigh(heavy)
)
)
) %>%
tab_style(
style = list(
cell_fill(color = 'lightblue'),
cell_text(weight = 'bold')
),
locations =
list(
cells_body(
columns = none,
rows = isLow(none)
),
cells_body(
columns = light,
rows = isLow(light)
),
cells_body(
columns = medium,
rows = isLow(medium)
),
cells_body(
columns = heavy,
rows = isLow(heavy)
)
)
)
On the basis of the comment I got, and after having read the earlier post here on SO, I came up with the following:
Create a dataset to work with:
mydata <- structure(list(none = c(4, 4, 25, 18, 10), light = c(2, 3, 10,
24, 6), medium = c(3, 7, 12, 33, 7), heavy = c(2, 4, 4, 13, 2
)), row.names = c("SM", "JM", "SE", "JE", "SC"), class = "data.frame")
Create a 'gt' table:
mytable <- gt::gt(mydata)
Create a vector of columns name to be later used inside the 'for' loops:
col.names.vect <- colnames(mydata)
Create two 'for' loops, one for each threshold upon which we want our values to be given different colors (say, a RED text for values > 20; a BLUE text for values < 5):
for(i in seq_along(col.names.vect)) {
mytable <- gt::tab_style(mytable,
style = gt::cell_text(color="red"),
locations = gt::cells_body(
columns = col.names.vect[i],
rows = mytable$`_data`[[col.names.vect[i]]] > 20))
}
for(i in seq_along(col.names.vect)) {
mytable <- gt::tab_style(mytable,
style = gt::cell_text(color="blue"),
locations = gt::cells_body(
columns = col.names.vect[i],
rows = mytable$`_data`[[col.names.vect[i]]] < 5))
}
This seems to achieve the goal I had in mind.
I am using the package formattable to format all data.frames of a list of data.frames.
For each data.frame, columns are compared with the previous one. Nevertheless as each data.frame contains different periods, the column names are changing.
I am looking for a manner to affect the same style to all columns of all data.frames without using column names.
For example, I start with the table below:
library(formattable)
df <- data.frame(2018 = runif(8),
2019 = runif(8),
2020 = runif(8))
tableF <-
formattable(df, list(
`2019`= formatter("span", style = ~ style(color = ifelse(`2019` >`2018`, "green", "red")),
~ icontext(ifelse(`2019` >`2018`,"arrow-up", "arrow-down"), `2019`)),
`2020`= formatter("span", style = ~ style(color = ifelse(`2020` >`2019`, "green", "red")),
~ icontext(ifelse(`2020` >`2019`,"arrow-up", "arrow-down"), `2020`))
))
tableF
But the next table I want to design is the following
df <- data.frame(2018_s1 = runif(8),
2018_s2 = runif(8),
2019_s1 = runif(8),
2019_s2 = runif(8),
2020_s1 = runif(8),
2020_s2 = runif(8))
Is there a way define a generic style and to affect it to multiple columns?
Something like:
target = colnames(df)[-1],
comp.target = colnames(df)[-ncol(df)],
style = ~ style(color = ifelse(target > comp.target, "green", "red")),
~ icontext(ifelse(target > comp.target,"arrow-up", "arrow-down"), target ))
Any help would be appreciated.
In the table below, how do I remove the line between the Canada row and the World row?
Also, how do I remove the bold from the column headers (ie 1980, 2019, Change)?
This is different than the proposed link in that I wonder if there is a solution that is of the form:
# Define styles
row_emphasis <- formatter("span", style = ~style("font.weight" = "bold", "font.size" = "18px"))
make_non_bold <- formatter("span", style = "font-style:italic; font-weight:normal")
# Apply styles
formattable(can_world_table, list(
area(row = 1) ~ row_emphasis,
# column headers # ~ make_non_bold
))
As for the part about removing the lines between rows, the suggested answer below does not address my issue. This code adds another line between Canada and the header row line:
row_emphasis <- formatter("span", style = ~style("font.weight" = "bold", "font.size" = "18px", "border-top: 1px solid green"))
library(tidyverse)
library(formattable)
target_year = 1980
current_year = 2019
can_target = 20.464
can2019 = 37.786
world_target = 6123
world2019 = 7456
can_change <- (can2019 - can_target) / can_target
world_change <- (world2019 - world_target) / world_target
can_world_table <- tibble(
region = c("Canada", "World"),
ty = c(round(can_target, digits = 0), round(world_target, digits = -2)),
cy = c(can2019, round(world2019, digits = -2)),
change = percent(c(can_change, world_change), 0)
) %>%
set_names(c("", target_year, current_year, "Change"))
can_world_table
can_world_table <- tibble(
region = c("Canada", "World"),
ty = c(can_target, format(round(world_target, digits = -2), big.mark = ",")),
cy = c(can2019, format(round(world2019, digits = -2), big.mark = ",")),
change = percent(c(can_change, world_change), 0)
) %>%
set_names(c(" ", target_year, current_year, "Change"))
row_emphasis <- formatter("span", style = ~style("font.weight" = "bold", "font.size" = "18px"))
formattable(can_world_table, list(
area(row = 1) ~ row_emphasis
))
I have two data.frames (each originally a dimension from a larger parent 3-d array). One holds numeric values. The other has T/F values indicating whether the confidence interval for each value in the first array overlaps a reference confidence interval. The confidence intervals are different for every value in the array, so in formatting the table I can’t refer to constants, only to the array of T/F values.
I want to show a table of the first array, with background color of each cell based on the second array. So that formattable can see the columns with T/F values, I created a single data frame that binds the columns from both 3rd dimensions. In the real data there are ~20 columns of numeric values. Here is a simplified example:
orig.data <- array(dim = c(3, 4, 2))
dimnames(orig.data) <- list (c("site1", "site2", "site3"), c("model1", "model2", "model3",
"model4"), c("mean.val", "is.in.CI"))
orig.data[,,1] <- round(runif(12, 2, 10), 2)
orig.data[,,2] <- as.logical(round(runif(12, 0, 1)))
ft.data <- data.frame(orig.data[,,2], stringsAsFactors = F)
colnames(ft.data) <- paste0("match.", colnames(ft.data))
ft.data <- cbind(data.frame(orig.data[,,1], stringsAsFactors = F),
ft.data)
I can create the table formatting I want by calling each column by name. There are two special considerations. First, for the first four columns, the choice of background color is conditional on a second column. Second, the last four columns I would like to hide. Is there a way to do this with apply or some similar succinct dynamic syntax?
Here is the long version that I’d like to consolidate.
yes.color <- "lightgreen"
no.color <- "pink"
formattable::formattable(ft.data, list(
`model1` = formatter("span", style = ~ style(display = "block",
"border-radius" = "4px", "padding-right" = "4px",
"background-color" = ifelse(`match.model1`, yes.color, no.color))),
`model2` = formatter("span", style = ~ style(display = "block",
"border-radius" = "4px", "padding-right" = "4px",
"background-color" = ifelse(`match.model2`, yes.color, no.color))),
`model3` = formatter("span", style = ~ style(display = "block",
"border-radius" = "4px", "padding-right" = "4px",
"background-color" = ifelse(`match.model3`, yes.color, no.color))),
`model4` = formatter("span", style = ~ style(display = "block",
"border-radius" = "4px", "padding-right" = "4px",
"background-color" = ifelse(`match.model4`, yes.color, no.color))),
match.model1 = F,
match.model2 = F,
match.model3 = F,
match.model4 = F))
This question is similar to the second of my questions and is unanswered: Loop, hide columns and r formattable
Failed attempts to automate hiding the T/F columns follow. I don’t have any ideas for automating the 2-column references.
formattable(ft.data[, 1:4])
If I omit the columns with the T/F designations, the formatter doesn’t know they exist.
area(col = 5:8) = F)) # no effect
Outside the formattable command, create a string:
formatter.string <- paste( unlist(paste0("match.", c(“model1”, “model2”, “model3”, “model4”), " = #F,\n\t")), collapse='')
then within the list for formattable, add
eval(parse(formatter.string)))) # no effect OR
lapply(5:8, function(m.col){m.col = F}) # also no effect
This is the best I could come up with using some eval / parse magic:
format <- sapply(names(ft.data)[1:4],function(x)
{
eval( #evaluate the following expression
parse(text= #parse the following string to an expression
sub("_SUB_", #find "_SUB_"
paste0("`match.",x,"`"), #replace with name of column
"formatter(\"span\", style = ~ style(display = \"block\", #in the string containing the formatter call
\"border-radius\" = \"4px\", \"padding-right\" = \"4px\",
\"background-color\" = ifelse(_SUB_, yes.color, no.color)))")))
},simplify=F,USE.NAMES = T)
#hiding part. Same concept as above
hide <- sapply(names(ft.data[5:8]), function(x) eval(parse(text=sub("_SUB_",x,"_SUB_ = F"))),
simplify=F,USE.NAMES=T)
formattable::formattable(ft.data,c(format,hide))
I am using RMarkdown to create a word document (I need the output to be in .docx format).
I'd like to use flextable (or any other package) to format my headers properly.
I'm trying to get the greek symbol delta (∆) to display properly... it seems possible because in the help pages here (https://davidgohel.github.io/flextable/articles/format.html#display-function) the author successfully uses \u03BC to insert the "μ" symbol (and I can too if I use his code, below), but I can't get it to work for delta using \u2206 or \u0394, if I replace \u03BC with either code below. The code I'm using produces this table, but I want to replace the highlighted bit with delta.
This is what I get when I try, for example, \u2206.
Any suggestions?
library(flextable)
if( require("xtable") ){
mat <- round(matrix(c(0.9, 0.89, 200, 0.045, 2.0), c(1, 5)), 4)
mat <- xtable(mat)
ft <- xtable_to_flextable(x = mat, NA.string = "-")
print(ft$col_keys)
ft <- flextable::display(ft, i = 1, col_key = "X1",
pattern = "{{val}}{{pow}}", part = "header",
formatters = list(val ~ as.character("R"), pow ~ as.character("2") ),
fprops = list(pow = fp_text(vertical.align = "superscript", font.size = 8))
)
ft <- flextable::display(ft, i = 1, col_key = "X2",
pattern = "{{val}}{{pow}}", part = "header",
formatters = list(val ~ as.character("\u03BC"), pow ~ as.character("x") ),
fprops = list(pow = fp_text(vertical.align = "superscript", font.size = 8))
)
ft <- flextable::display(ft, i = 1, col_key = "rowname",
pattern = "{{val}}{{pow}}", part = "body",
formatters = list(val ~ as.character("y"), pow ~ as.character("t-1") ),
fprops = list(pow = fp_text(vertical.align = "subscript", font.size = 8))
)
ft <- set_header_labels(ft, X3 = "F-stat", X4 = "S.E.E", X5 = "DW", rowname = "")
ft <- autofit(ft)
ft
}
Update
I am getting closer thanks to a helpful suggestion from David, but (not being very familiar with flextable) I am getting strange behaviour when I try to modify the header in the way suggested:
library(magrittr)
library(flextable)
library(officer)
AICtable <- data.frame(Model = "test", Parameters = 9, AICc = 4000, dAICc = 0, w = 1)
v.epi.aic <- flextable(AICtable) %>%
font(fontname = "Times New Roman", part = "all") %>%
flextable::display(col_key = "dAICc", part = "header",
pattern = "{{D}}{{A}}{{cbit}}",
formatters = list(D ~ as.character("D"),
A ~ as.character("AIC"),
cbit ~ as.character("c") ),
fprops = list(D = fp_text(font.family = "Symbol"),
A = fp_text(font.family = "Times New Roman"),
cbit = fp_text(vertical.align = "subscript")))
v.epi.aic
Notice that column headers are now duplicated, and "AIC" appears before the "∆". The column names should be:
Model, Parameters, AICc, ∆AICc, w (and the "c" in the ∆AICc should be a subscript).
Please use "\u394" instead of "\u0394" to generate the capital delta symbol