Shade table with extraKable in RMarkdown for pdf using dplyr mutate? - r

I am wanting to apply different color shading to a table based on different value sets. I am creating this table in Rmarkdown using kableExtra. I want values between 0 and <.10 to be left alone. Values >=.10 and <.20 to be shaded yellow. and values >=.20 to be shaded red.
df
name category 1 categry 2 category a category b
ab .01 .45 .19 .09
410 .12 .01 .05 .66
NW 5th .25 .22 .01 .16
This is what I have been making my existing table with:
library(knitr)
library(dplyr)
kable(df, caption = "warning values", digits = 2, format = "latex",
booktabs = T)%>%
kable_styling(latex_options = c("striped"))%>%
landscape()%>%
row_spec(0, angle = 45)
I'm not sure how to use the mutate and cel_spec functions to apply to the entire table. The table columns and row names change dynamically with every report fyi.
EDIT: Martin's answer works great. Until I tried to clean up my numbers. My actual input file has more digits, like Martin's answer. It also has file and row names that include an underscore. (That caused issues when using this answer, but I found a workaround.)
#replace any "_" with escaped "\\_" for magrittR/latex compatability
names(df) <- gsub(x = names(df), pattern = "\\_", replacement =
"\\\\_")
df$name <- gsub('\\_', '\\\\_', df$name)
#format numbers
df <- format(df, digits=0, nsmall=3, scientific = FALSE)
The replacement works fine, its the number formatting that breaks the answer. Everything still executes just fine, but I lose the colorized table.
Thoughts?

Here is way to do this. Notice that I used the compund assignment operator from magrittr.
---
title: test
output: pdf_document
---
```{r, echo = F, warning = F, message = F}
library(knitr)
library(dplyr)
library(kableExtra)
library(magrittr)
df <- data.frame(A = runif(4, 0, 1), B = runif(4, 0, 1), row.names = letters[1:4])
paint <- function(x) { # our painting function
ifelse(x < 0.1, "white", ifelse(x < 0.2, "yellow", "red"))
}
df %<>%. # compound assignment operator
mutate_if(is.numeric, function(x) { # conditional mutation, if the column type is numeric
cell_spec(x, background = paint(x), format = "latex")
})
kable(df, caption = "warning values", digits = 2, format = "latex",
booktabs = T, escape = F) %>%
landscape()%>%
row_spec(0, angle = 45)
```

Related

Missing symbols when combining formattable and kableExtra when creating a data-table in R

I'm attempting to combine the use of R packages formattable and kableExtra to create a data-table. Using formattable, I'm adding a green thumbs up symbol to one particular column ("b") for numbers > 0, this displays correctly. I then pass my table to "kable" so that I can add the "hover" feature, widen column 1, and add grouped headers. However, whilst the produced data-table correctly displays the "hover" feature and correct grouped headers, the green thumbs up feature (derived from formattable) is missing.
Here is a minimal, reproducible example:
library(formattable)
library(kableExtra)
library(dplyr)
labels <- c("A", "B", "C")
a <- c(0.22, 0.28, 0.23)
b <- c(890.53, 346.84, 1119.63)
c <- c(6.56, 5.70, 4.59)
d <- c(0.0048, -0.3194, -0.2720)
e <- c(-0.3212, 0.1280, 0.0755)
f <- c("-", "-", "-")
df <- tibble(labels,a,b,c,d,e,f)
customGreen = "#71CA97"
# function to assign a thumbs up to numbers > 0
custom_thumb <- formatter("span", style = x ~ style(font.weight = "bold",
color = ifelse(x > 0, customGreen, ifelse(x < 0, customRed, "black"))),
x ~ icontext(ifelse(x > 0, "thumbs-up", ""), x)
)
# use formattable to add thumbs up symbols
df_frmt <- formattable(df, align =c("l","c","c","c","c","c","c"),
list(`labels` = formatter("span"),
`b` = custom_thumb))
# pass the resulting table to kable for further edits
df_kbl <- kbl(df_frmt, escape = T) %>%
kable_styling("hover", full_width = F) %>%
column_spec(1, width = "5cm") %>%
add_header_above(c(" "=2, "Group 1" = 2, "Group 2" = 2, " " = 1))
df_kbl
Given that the hover feature and grouped headers is working well, is the issue something to do with escaping html? I've tried both "escape=T" and "escape=F" in the kable edit though there's no change. I know that both of these packages can be used together from reading the "Integration with formattable" section of this website. I don't know if it's relevant or not, but I'm running this code in an RMarkdown file inside RStudio. Any helps is appreciated!
Following your mentioned link, combining formattable and kableExtra is not done by passing a formattable to the kbl function.
Instead you might use custom (your custom_thumb) or original functions (color_bar or color_tile) from formattable and integrate them into the kableExtra syntax.
df %>%
mutate(b = custom_thumb(b)) %>%
kable("html", escape = F, align = c("l","c","c","c","c","c","c")) %>%
kable_styling("hover", full_width = F) %>%
column_spec(1, width = "5cm") %>%
add_header_above(c(" " = 2, "Group 1" = 2, "Group 2" = 2, " " = 1))

Partially bold colunm headers with gt

I want to use the R package gt and have the table output ONE and TWO in bold. It looks like you can use markdown syntax inside gt but this doesn't quite work as I'd expect. Any tips?
dummy <- tibble(
`**ONE**, N = 1` = 1,
`**TWO**, N = 2` = 2
)
dummy %>%
gt()
Couldn't see anyway to do exactly what you want but this accomplishes it by having a list that maps column names to label name with formatting.
library(tibble)
library(gt)
dummy <- tibble(
"one" = 1,
"two" = 2
)
col_for_list <- list(one = md("**ONE**, N = 1"), two = md("**TWO**, N = 2"))
dummy %>%
gt::gt() %>%
cols_label(.list = col_for_list)

conditionally format dynamically created table in R

I would like to render a table in R, with cells formatted according to some non-trivial logic. (e.g. if a value is odd, color the cell yellow; if it is also >5, make the text bold, etc.). This logic would be applied to each column of a dynamically created table, i.e. the column names are unknown so cannot be used in the code.
If found this JQuery approach helpful, but I'm not sure it completely solves my problem, plus I would prefer an R-based approach.
I also came close using the condformat package, but for some reason the following doesn't work:
library(condformat)
data(iris)
# Create a condformat object
cf <- condformat(iris)
# Add rules to it:
for (col in colnames(iris)[1:2]) {
cf <- cf %>% rule_css(!!col,
expression = ifelse(eval(parse(text=col)) < 3.3, "red", "black"),
css_field = 'color')
}
# Render it
cf
The first column of the resulting table doesn’t abide by the rule; instead, it is given the colors from column 2. But if I instead loop over just that first column, the coloring for it is correct.
Any help with the above code, or with the problem generally, would be greatly appreciated.
kableExtra is a very powerful tool for creating HTML tables in R.
library(kableExtra)
iris[1:10, 1:2] %>%
mutate(
Sepal.Length = cell_spec(
Sepal.Length,
"html",
background = ifelse(Sepal.Length %% 2 == 1, "yellow", "red"),
bold = ifelse(Sepal.Length > 5, T, F)
),
Sepal.Width = cell_spec(
Sepal.Width,
"html",
background = ifelse(Sepal.Width %% 2 == 1, "blue", "green"),
bold = ifelse(Sepal.Width > 10, T, F)
),
) %>%
kable(format = "html", escape = F) %>%
kable_styling("striped", full_width = F)
Please refer to the documentation for additional details:
Create Awesome HTML Table with knitr::kable and kableExtra
In order to do this on a dynamic table, you could loop over the columns of the data.frame like this (taking most of the code from Ozan147's answer):
library(kableExtra)
test <- iris[1:10, ]
for(i in 1:ncol(test)){
if(is.numeric(test[[i]])){
test[[i]] <- cell_spec(
test[[i]],
"html",
background = ifelse(test[[i]] %% 2 == 1, "yellow", "red"),
bold = ifelse(test[[i]] > 5, T, F)
)
}
}
test %>%
kable(format = "html", escape = F) %>%
kable_styling("striped", full_width = F)

Table in r with multiple sub rows and write to pdf

Is it possible to generate a table in R with multiple rows correspondng to a single row? And write the resultant table to a pdf. The sample table is as below.
Is it possible to join two seperate tables in the way showed in the image.
Sample code for the two tables are given below
tab1="Test Description
1 test1 description
2 test2 description"
table1 <-read.table(text = tab1,header = TRUE)
tab21="Cause Probability Feedback
1 cause1 .5 positive
2 Cause2 .2 negative
3 Cause3 .1 negative
4 Cause4 .2 negative"
table2 <-read.table(text = tab21,header = TRUE)
tab22="Cause Probability Feedback
1 cause1 .7 positive
2 Cause2 .2 negative
3 Cause3 .1 negative"
table3 <-read.table(text = tab22,header = TRUE)
It is a little bit tricky, but I'd take advantage of the fact that cells with NAs are printed as empty by the print.xtable-function. The cells are not truly 'merged', but it looks like it when the contents are aligned to the top.
Basically the steps are:
Generate a suitable data.frame in R
Print this as a .tex compatible table using print.xtable from the package 'xtable'
Use Sweave/knitr/etc to generate a suitable .tex
tools::texi2pdf will then convert your .tex to a suitable .pdf
Here are the files, you need to only source the RunSweave.R in your R terminal (and make sure you have LaTeX installed along with the required packages, i.e. 'xtable and have the files in a single folder; this was run in Windows).
File StackExampleCode.R:
# StackExampleCode.R
library(xtable)
# A work-around by setting rows in the multi-row to NA after the initial top-justified line
header <- data.frame(test = "Tests", det = "Details", cause = "Cause", prob = "Probability", fb = "Feedback")
# Filling the fields for these is something you'd probably want to do in R in a more sophisticated manner
test1 <- data.frame(
test = c("Test 1", NA, NA, NA, NA),
det = c("Description", NA, NA, NA, NA),
cause = c("Cause 1", NA, paste("Cause", 2:4)),
prob = c(".5", NA, ".2", ".1", ".2"),
fb = c("positive", NA, "negative", "negative", "negative")
)
test2 <- data.frame(
test = c("Test 2", NA, NA, NA),
det = c("Description", NA, NA, NA),
cause = c(paste("Cause", 1:3), NA),
prob = c(".7", ".1", ".2", NA),
fb = c("positive", "negative", "negative", NA)
)
# Bind it all together, you probably want something similar if it's automatic data you're generating
tab <- rbind(header, test1, test2)
File StackExampleRnw.Rnw:
% StackExampleRnw.Rnw
% Note the different comment char, writing .tex here
\documentclass{article}
\begin{document}
<<echo=FALSE, results=tex>>=
# Printing the table
print(
xtable(tab,
align = "|l|l|l|l|l|l|" # Create the desired vertical lines and text alignments ala LaTeX; left align with vertical lines in-between each column)
),
add.to.row = list( # Add horizontal lines to correct spots, should be adjusted according to the desired data
pos = list(-1, 1, 6, nrow(tab)),
command = c("\\hline \n", "\\hline \n", "\\hline \n", "\\hline \n") # Horizontal lines and a neater formatting of output using a linechange
),
include.rownames = FALSE, # Don't include the rownames (which would be just numbers)
include.colnames = FALSE, # Don't include the rownames, these were already included as if it was an ordinary table row
hline.after = NULL # Suppress the empty horizontal line that is intended for an automated caption
)
#
\end{document}
File RunSweave.R:
# RunSweave.R
# Run the code
source("StackExampleCode.R")
# Bundle R code with LaTeX
Sweave("StackExampleRnw.Rnw")
# .tex -> .pdf
tools::texi2pdf("StackExampleRnw.tex")
Here's what it looks like for me in StackExampleRnw.pdf:
Alternatively, you can directly access the table in .tex in the file StackExampleRnw.tex and do some additional formatting if you're comfortable with it. Above doesn't require any additional tinkering in .tex, but you need to make sure you put the horizontal lines and NAs to correct places.
If you're not comfortable with .tex, the print.xtable-function has plenty of parameters available for further formatting. If the partial horizontal lines are really important for you in the three columns to the right, I'd probably split this into two tables and then just glue them together horizontally and have the right one with a horizontal line in each row.
I would have liked to accomplish this in pixiedust by merging some cells, but it appears I have a flaw in pixiedust that doesn't allow for vertical borders on merged rows. The workaround uses Teemu's approach of setting the cells we don't wish to view to NA and directing them to be printed as empty characters.
library(dplyr)
library(pixiedust)
table2$Test <- "test1"
table3$Test <- "test2"
bind_rows(
right_join(table1, table2),
right_join(table1, table3)
) %>%
mutate(Description = as.character(Description)) %>%
group_by(Test) %>%
mutate(Description = ifelse(duplicated(Description), NA, Description)) %>%
ungroup() %>%
mutate(Test = ifelse(duplicated(Test), NA, Test))%>%
dust(float = FALSE) %>%
sprinkle(cols = 1:2,
rows = c(4, 7),
border = "bottom") %>%
sprinkle(cols = 1:2,
rows = 1,
border = "top") %>%
sprinkle(cols = 1:2,
border = "left",
na.string = "") %>%
medley_all_borders(cols = 3:5) %>%
medley_all_borders(part = "head") %>%
sprinkle_print_method("latex")
A full, working RMD file would be:
---
title: "Untitled"
output: pdf_document
header-includes:
- \usepackage{amssymb}
- \usepackage{arydshln}
- \usepackage{caption}
- \usepackage{graphicx}
- \usepackage{hhline}
- \usepackage{longtable}
- \usepackage{multirow}
- \usepackage[dvipsnames,table]{xcolor}
---
```{r, echo = FALSE, message = FALSE, warning = FALSE}
library(dplyr)
library(pixiedust)
tab1="Test Description
1 test1 description
2 test2 description"
table1 <-read.table(text = tab1,header = TRUE)
tab21="Cause Probability Feedback
1 cause1 .5 positive
2 Cause2 .2 negative
3 Cause3 .1 negative
4 Cause4 .2 negative"
table2 <-read.table(text = tab21,header = TRUE)
tab22="Cause Probability Feedback
1 cause1 .7 positive
2 Cause2 .2 negative
3 Cause3 .1 negative"
table3 <-read.table(text = tab22,header = TRUE)
```
```{r, echo = FALSE, message = FALSE, warning = FALSE}
table2$Test <- "test1"
table3$Test <- "test2"
bind_rows(
right_join(table1, table2),
right_join(table1, table3)
) %>%
mutate(Description = as.character(Description)) %>%
group_by(Test) %>%
mutate(Description = ifelse(duplicated(Description), NA, Description)) %>%
ungroup() %>%
mutate(Test = ifelse(duplicated(Test), NA, Test))%>%
dust(float = FALSE) %>%
sprinkle(cols = 1:2,
rows = c(4, 7),
border = "bottom") %>%
sprinkle(cols = 1:2,
rows = 1,
border = "top") %>%
sprinkle(cols = 1:2,
border = "left",
na.string = "") %>%
medley_all_borders(cols = 3:5) %>%
medley_all_borders(part = "head")
```

Xtable two columns using longtable customizations

This is a continuation of a question I posted earlier. I have a code.Rnw file in RStudio which I knit into a code.tex file using knit("code.Rnw") command.
I have a data frame that I am printing using the xtable command. In the example below, it is 20 rows. However, to save space, I am printing it out as two columns, each with 10 rows.
Below is my code:
\documentclass[11pt, a4paper]{article}
\usepackage[margin=3cm]{geometry}
\usepackage{longtable}
\begin{document}
<<echo=FALSE,results='asis'>>=
library(xtable)
set.seed(1)
spaceCol = rep(" ",10)
df1 = data.frame(student = letters[1:10], vals=runif(10, 1, 10))
df2 = data.frame(student = letters[11:20], vals=runif(10, 1, 10))
dfFull = data.frame(df1,spaceCol,df2)
names(dfFull) = c(" ","% Correct"," "," ", "% Correct")
row.names(dfFull) = NULL
x.big <- xtable(dfFull, label ='tabtwo',caption ='Caption for table with student scores')
print(x.big, tabular.environment ='longtable', floating = FALSE, include.rownames=FALSE)
#
\end{document}
This is what the output looks like:
I like the aesthetics of this output, especially because in the longtable format, this output will automatically page-break if need be. However, what I am trying to improve, is to make it more easy to visualize that this output is really two distinct columns.
To do that, I would like to add a space between the two columns, so the output looks more as follows:
However, if that proves impossible, then I could consider something like adding a vertical line to distinguish the two columns, as shown below:
How might this be possible given my limitation in using xtable?
\documentclass[11pt, a4paper]{article}
\usepackage{subfig}
\begin{document}
<<echo = FALSE>>=
library(xtable)
opts_chunk$set(
echo = FALSE,
results = 'asis'
)
set.seed(1)
mynames <- c("", "% Correct")
df1 = data.frame(letters[1:10], runif(10, 1, 10))
df2 = data.frame(student = letters[11:20], vals=runif(10, 1, 10))
colnames(df1) <- mynames
colnames(df2) <- mynames
#
\begin{table}\centering
\subfloat{
<<>>=
print(xtable(df1), floating = FALSE, include.rownames = FALSE)
#
} \hspace{2cm}
\subfloat{
<<>>=
print(xtable(df2), floating = FALSE, include.rownames = FALSE)
#
}
\caption{Caption for table with student scores} \label{tabtwo}
\end{table}
\end{document}
The only drawback is, that you cannot use longtable with this approach.
UPDATE: Here is an alternative that makes use of longtable. The trick is to use xtable for the contents of the table only and build the headline by hand, so you have full control over all lines etc. I decided to use an empty column for the space because making column 2 wider would make the horizontal lines look ugly.
\documentclass{article}
\usepackage{longtable}
\begin{document}
\thispagestyle{empty}
<<echo = FALSE>>=
library(xtable)
opts_chunk$set(
echo = FALSE,
results = 'asis'
)
set.seed(1)
df1 = data.frame(letters[1:10], runif(10, 1, 10))
df2 = data.frame(student = letters[11:20], vals=runif(10, 1, 10))
dfFull <- cbind(df1, NA, df2)
#
\begin{longtable}{lrl#{\hskip 2cm}lr} \cline{1-2} \cline{4-5}
& \% Correct & & & \% Correct \\ \cline{1-2} \cline{4-5}
<<>>=
print(xtable(dfFull), only.contents = TRUE, include.rownames = FALSE, include.colnames = FALSE, hline.after = NULL)
#
\cline{1-2} \cline{4-5}
\caption{Caption for table with studen scores} \label{tabtwo}
\end{longtable}
\end{document}
UPDATE2: Finally, a solution that uses longtable and doesn't involve creating half of the table "by hand". The trick is to remove all horizontal lines (hline.after = NULL) and than add \clines where required using add.to.row (inspired by this question).
\documentclass{article}
\usepackage{longtable}
\begin{document}
\thispagestyle{empty}
<<echo = FALSE, results = 'asis'>>=
library(xtable)
set.seed(1)
df1 = data.frame(letters[1:10], runif(10, 1, 10))
df2 = data.frame(letters[11:20], runif(10, 1, 10))
dfFull <- cbind(df1, NA, df2)
# To test "longtable", rbind data several times:
multiply <- 5
dfFull <- do.call("rbind", replicate(multiply, dfFull, simplify = FALSE))
colnames(dfFull) <- c("", "% Correct", "", "", "% Correct")
print(xtable(dfFull,
caption = "Caption for table with student scores",
label = "tabtwo",
align = c("l", # ignored (would apply to colnames)
"l", "r",
"l#{\\hskip 2cm}", # space between blocks
"l", "r")),
include.rownames = FALSE,
include.colnames = TRUE,
hline.after = NULL, # Remove all default lines. A line after the very last row remains, which is automatically added when using "longtable".
tabular.environment = "longtable",
floating = FALSE,
add.to.row = list(
pos = list(-1, 0),
command = rep("\\cline{1-2} \\cline{4-5}", 2))
)
#
\end{document}

Resources