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.
Related
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])))
With sample data and code below, I'm able to dynamically draw gt() plots for each element of list of dataframes, and I set color for error column:
df <- structure(list(id = c("M0000607", "M0000609", "M0000612"), `2021-08(actual)` = c(12.6,
19.2, 8.3), `2021-09(actual)` = c(10.3, 17.3, 6.4), `2021-10(actual)` = c(8.9,
15.7, 5.3), `2021-11(actual)` = c(7.3, 14.8, 3.1), `2021-12(actual)` = c(6.1,
14.2, 3.5), `2021-08(pred)` = c(11.65443222, 14.31674997, 7.084180415
), `2021-09(pred)` = c(12.29810914, 17.7143733, 6.057927385),
`2021-10(pred)` = c(9.619846116, 15.54553601, 6.525992602
), `2021-11(pred)` = c(8.352097939, 13.97318204, 3.164682627
), `2021-12(pred)` = c(6.113631596, 14.16243166, 3.288372517
), `2021-08(error)` = c(2.082307066, 1.146759554, 0.687406723
), `2021-09(error)` = c(1.631350383, 2.753457736, 2.952737781
), `2021-10(error)` = c(0.945567783, 4.883250027, 1.215819585
), `2021-11(error)` = c(1.998109138, 0.414373304, 0.342072615
), `2021-12(error)` = c(0.719846116, 0.154463985, 1.225992602
)), class = "data.frame", row.names = c(NA, -3L))
year_months <- c('2021-12', '2021-11', '2021-10')
curr <- lubridate::ym(year_months)
prev <- curr - months(2L)
dfs <- mapply(function(x, y) {
df[c(
"id",
format(seq.Date(y, x, by = "month"), "%Y-%m(actual)"),
format(x, "%Y-%m(pred)"),
format(x, "%Y-%m(error)")
)]
}, curr, prev, SIMPLIFY = FALSE)
plotGT <- function(data){
plot <- data %>%
gt() %>%
data_color(
columns = 6, # set color for error column
colors = scales::col_numeric(
palette =
c("blue", "green", "orange", "red"), # named with color 1
# c('#feb8cd', '#ffffff', '#69cfd5'), # named with color 2
domain = c(0, 10)
)
)
print(plot)
# gtsave(plot, file = file.path(glue("./plot_color1.png")))
}
mapply(plotGT, dfs)
Result for colors c("blue", "green", "orange", "red"):
Result for colors c('#feb8cd', '#ffffff', '#69cfd5'):
In order to go further, I hope to save the outputs based if conditions: if I choose the first color palette, I will name the plot by i.e., plot_color1.png, for the second, named by plot_color2.png, but I wish to run the whole code once, save all two figures one time.
So my question is how could I modify the code above to achieve that? Thanks for your help at advance.
Maybe some code like: gtsave(plot, file = file.path(glue("./plot_color{i}.png"))) based on if-else conditions, but I don't know how to do that exactly.
One option would be to make use of a named list of color palettes like so, which would also make it easier to switch between different palettes:
EDIT
I fixed a bug. I used a <- inside the pals list instead of = which was the reason for the error you got.
To loop over the palettes I added pal_choice as an argument to your table function. Doing so we can loop over pals using e.g. lapply.
Additionally, as you are looping over multiple dfs I added a name argument and added names to your list of data frames. As is the tables were exported under the same filename so actually you ended up with one file containing the last table.
I also uncommented the print for the reprex.
library(gt)
pal_choice <- "color2"
pals <- list(color1 = c("blue", "green", "orange", "red"),
color2 = c('#feb8cd', '#ffffff', '#69cfd5'))
plotGT <- function(data, name, pal_choice){
plot <- data %>%
gt() %>%
data_color(
columns = 6, # set color for error column
colors = scales::col_numeric(
palette = pals[[pal_choice]],
domain = c(0, 10)
)
)
#print(plot)
gtsave(plot, file = glue::glue("./plot_{name}_{pal_choice}.png"))
}
names(dfs) <- letters[seq_along(dfs)]
lapply(names(pals), function(x) {
mapply(plotGT, dfs, names(dfs), MoreArgs = list(pal_choice = x))
})
#> [[1]]
#> a
#> "/private/var/folders/l7/hltv70p95zqfdq9z09h8m9bw0000gn/T/Rtmp9LLLHO/reprex-2b71746b0fd-petit-dore/plot_a_color1.png"
#> b
#> "/private/var/folders/l7/hltv70p95zqfdq9z09h8m9bw0000gn/T/Rtmp9LLLHO/reprex-2b71746b0fd-petit-dore/plot_b_color1.png"
#> c
#> "/private/var/folders/l7/hltv70p95zqfdq9z09h8m9bw0000gn/T/Rtmp9LLLHO/reprex-2b71746b0fd-petit-dore/plot_c_color1.png"
#>
#> [[2]]
#> a
#> "/private/var/folders/l7/hltv70p95zqfdq9z09h8m9bw0000gn/T/Rtmp9LLLHO/reprex-2b71746b0fd-petit-dore/plot_a_color2.png"
#> b
#> "/private/var/folders/l7/hltv70p95zqfdq9z09h8m9bw0000gn/T/Rtmp9LLLHO/reprex-2b71746b0fd-petit-dore/plot_b_color2.png"
#> c
#> "/private/var/folders/l7/hltv70p95zqfdq9z09h8m9bw0000gn/T/Rtmp9LLLHO/reprex-2b71746b0fd-petit-dore/plot_c_color2.png"
I am trying to build a formattable with two columns, one a metric category and the other a trend indicator. For the trend I would like to use various direction arrows using the extended characters in the loaded font set. These can be referenced using the "&#xnnnn;" notation.
However, whenever I specify a specific formatter for the trend the translation fails and the arrow character is not displayed (the string representation is!).
In the code below, the first print works (using textout1); the second fails.
library(formattable)
metric <- "Quality"
trend <- "↑"
thetext <- data.frame("Metric" = metric, "Trend" = trend)
f1 <- formattable::formatter("span", style = ~ style(color = "#0066CC", "font-family" = "Cambria"))
f2 <- formattable::formatter("span", style = ~ style(color = "#00FF00", "font-family" = "Cambria",
font.weight = "bold"))
textout1 <- formattable::formattable(thetext, align = c("l", "l"), list("Metric" = f1))
textout2 <- formattable::formattable(thetext, align = c("l", "l"), list("Metric" = f1, "Trend" = f2))
print (formattable(textout1))
print (formattable(textout2))
I have the following 3 way table I created in R.
with(dataset, ftable(xtabs(count ~ dos + sex + edu)))
The output looks like
edu high low medium unknown
dos sex
five-to-ten-years female 247776 44916 127133 23793
male 225403 37858 147821 20383
five-years-or-less female 304851 58018 182152 33649
male 253977 55720 193621 28972
more-than-ten-years female 709303 452605 539403 165675
male 629162 309193 689299 121336
native-born female 1988476 1456792 2094297 502153
male 1411509 1197395 2790522 395953
unknown female 57974 75480 73204 593141
male 40176 57786 93108 605542
I want to rename the variables and format the table so that I can include it in a report. I know that I can use dnn to rename the variables, but are there any other recommendations to rename the variables? And to format the table (similar to using kable)?
You could convert the output to a text matrix using the following function, after which you can style with kable however you choose:
ftab_to_matrix <- function(ft)
{
row_vars <- attr(ft, "row.vars")
for(i in seq_along(row_vars)){
row_vars[[i]] <- c(names(row_vars[i]), row_vars[[i]])}
rowvar_widths <- sapply(row_vars, function(x) max(nchar(x))) + 1
col_vars <- attr(ft, "col.vars")
rowvar_widths <- c(1, cumsum(c(rowvar_widths, max(nchar(names(col_vars))))))
ft_text <- capture.output(print(ft))
row_cols <- sapply(seq_along(rowvar_widths)[-1], function(x)
substr(ft_text, rowvar_widths[x - 1], rowvar_widths[x]))
ft_text <- substr(ft_text, rowvar_widths[length(rowvar_widths)] + 2, 100)
ft_breaks <- c(1, cumsum(lapply(strsplit(ft_text[length(ft_text)], "\\d "),
function(x) nchar(x) + 2)[[1]]))
col_cols <- sapply(seq_along(ft_breaks)[-1], function(x)
substr(ft_text, ft_breaks[x - 1], ft_breaks[x]))
trimws(cbind(row_cols, col_cols))
}
So, for example, using my example data from your last question, you could do something like:
my_tab <- with(`3waydata`, ftable(xtabs(count ~ duration + sex + education)))
as_image(kable_styling(kable(ftab_to_df(my_tab))), file = "kable.png")
Might have been easier had you given the full picture when you asked your first question... You could use gt to make fancy tables for reports. This is an edited version more fully demonstrating some capabilities.
library(dplyr)
library(gt)
way3data <- data %>%
group_by(duration, education, sex) %>%
summarise(count = sum(number)) %>%
ungroup
# Reorder with select and Titlecase with stringr
longer <- tidyr::pivot_wider(way3data,
values_from = count,
names_from = "education") %>%
select(duration, sex, high, medium, low, unknown) %>%
rename_with(stringr::str_to_title)
# Demonstrating some of the features of gt
# obviously could have done some of this
# to the original dataframe
myresults <- longer %>%
group_by(Duration) %>%
gt(rowname_col = "Sex") %>%
row_group_order(
groups = c("native-born",
"more-than-ten-years",
"five-to-ten-years",
"five-years-or-less",
"unknown")
) %>%
tab_spanner(label = "Education",
columns = matches("High|Low|Medium|Unknown")) %>%
tab_stubhead(label = "Duration or something") %>%
tab_style(
style = cell_text(style = "oblique", weight = "bold"),
locations = cells_row_groups()) %>%
tab_style(
style = cell_text(align = "right", style = "italic", weight = "bold"),
locations = cells_column_labels(
columns = vars(High, Low, Medium, Unknown)
)) %>%
tab_style(
style = cell_text(align = "right", weight = "bold"),
locations = cells_stub()) %>%
tab_header(
title = "Fancy table of counts with Duration, Education and Gender") %>%
tab_source_note(md("More information is available at https://stackoverflow.com/questions/62284264."))
# myresults
# Can save in other formats including .rtf
myresults %>%
gtsave(
"tab_1.png", expand = 10
)
You can read about all the formatting choices here
Data compliments of Allan
set.seed(69)
data <- data.frame(education = sample(c("high","low","medium","unknown"), 600, T),
sex = rep(c("Male", "Female"), 300),
duration = sample(c("unknown", "native-born",
"five-years-or-less", "five-to-ten-years",
"more-than-ten-years"), 600, T),
number = rpois(600, 10))
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))