HTML is basically a superpower.
gt
loves HTMLgt
really does love HTML, and for now, gt
is HTML-first which is great since HTML can do SOO many things in R Markdown, shiny
, and elsewhere.
A gt
table can always be saved as an .png
or .pdf
file if you need to incorporate it in non-HTML content. Lastly, gt
does have preliminary support for RTF, and could export to a PDF via gtsave()
.
gt
allows for HTML to be incorporated in MANY different locations with gt::html()
. For example, we can use a <span style>
to color the title for this table, and another <span style>
to change the font size and weight for one off column. This really just scratches the surface of what is possible, and mostly you are free to use a lot of your creativity in building these tables.
As a note - it’s worth learning a bit more about how HTML works, as it will help with building R Markdown content, shiny
, your personal website, and the syntax is used in the ggtext
package, so it’ll help with ggplot2
as well! For a lot of this we’re nesting HTML, things should really just work, BUT if you run into problems getting some HTML content to export into content, you can try a R Markdown
chunk with results='asis'
, along with gt() %>% as_raw_html(inline_css = TRUE)
.
Also, if you want to learn a bit more CSS/HTML to adjust tables beyond what I’ve shown below - check out either Mozilla Docs or the W3schools.
nfl_qbr <- espnscrapeR::get_nfl_qbr(2020) %>%
slice(1:10)
ex_tab <- nfl_qbr %>%
select(rank, last_name, team, qbr_total, qb_plays, pass, run) %>%
gt() %>%
tab_header(
title = gt::html("<span style='color:red'>ESPN's QBR for 2020</span>")
) %>%
cols_label(
qbr_total = gt::html(
"<span style ='font-weight:bold;font-size:20px'>QBR</span>")
)
ex_tab
ESPN's QBR for 2020 | ||||||
---|---|---|---|---|---|---|
rank | last_name | team | QBR | qb_plays | pass | run |
1 | Mahomes | KC | 86.1 | 513 | 91.2 | 13.3 |
2 | Rodgers | GB | 85.1 | 433 | 69.2 | 6.3 |
3 | Brees | NO | 81.1 | 328 | 53.6 | 1.0 |
4 | Prescott | DAL | 79.0 | 263 | 31.2 | 4.9 |
5 | Tannehill | TEN | 76.7 | 413 | 48.9 | 11.7 |
6 | Allen | BUF | 75.4 | 513 | 72.2 | 9.4 |
7 | Wilson | SEA | 74.9 | 514 | 68.3 | 5.4 |
8 | Watson | HOU | 74.2 | 471 | 58.8 | 9.2 |
9 | Fitzpatrick | MIA | 73.7 | 311 | 38.1 | 5.6 |
10 | Carr | LV | 73.6 | 417 | 54.4 | 4.8 |
So that’s cool to see where things can be changed, but let’s walk through a bit more engaging example. Here we’re going to merge some columns for the Player’s last name + team.
ex_tab <- nfl_qbr %>%
select(rank, last_name, team, qbr_total, qb_plays, pass, run) %>%
gt()
ex_tab %>%
cols_merge(
columns = vars(last_name, team)
)
rank | last_name | qbr_total | qb_plays | pass | run |
---|---|---|---|---|---|
1 | Mahomes KC | 86.1 | 513 | 91.2 | 13.3 |
2 | Rodgers GB | 85.1 | 433 | 69.2 | 6.3 |
3 | Brees NO | 81.1 | 328 | 53.6 | 1.0 |
4 | Prescott DAL | 79.0 | 263 | 31.2 | 4.9 |
5 | Tannehill TEN | 76.7 | 413 | 48.9 | 11.7 |
6 | Allen BUF | 75.4 | 513 | 72.2 | 9.4 |
7 | Wilson SEA | 74.9 | 514 | 68.3 | 5.4 |
8 | Watson HOU | 74.2 | 471 | 58.8 | 9.2 |
9 | Fitzpatrick MIA | 73.7 | 311 | 38.1 | 5.6 |
10 | Carr LV | 73.6 | 417 | 54.4 | 4.8 |
This saves us some space since we’re dropping a column, but isn’t the prettiest thing. Let’s use an anonymous function and text_transform
to change the styling of our player’s name/team with <span style>
along with small caps, different font colors and sizes.
ex_tab %>%
cols_merge(
columns = vars(last_name, team)
) %>%
text_transform(
locations = cells_body(
columns = vars(last_name)
),
fn = function(x){
name <- word(x, 1)
team <- word(x, -1)
glue::glue(
"<div><span style='font-weight:bold;font-variant:small-caps;font-size:14px'>{name}</div>
<div><span style ='font-weight:bold;color:grey;font-size:10px'>{team}</span></div>"
)
}
)
rank | last_name | qbr_total | qb_plays | pass | run |
---|---|---|---|---|---|
1 | Mahomes
KC |
86.1 | 513 | 91.2 | 13.3 |
2 | Rodgers
GB |
85.1 | 433 | 69.2 | 6.3 |
3 | Brees
NO |
81.1 | 328 | 53.6 | 1.0 |
4 | Prescott
DAL |
79.0 | 263 | 31.2 | 4.9 |
5 | Tannehill
TEN |
76.7 | 413 | 48.9 | 11.7 |
6 | Allen
BUF |
75.4 | 513 | 72.2 | 9.4 |
7 | Wilson
SEA |
74.9 | 514 | 68.3 | 5.4 |
8 | Watson
HOU |
74.2 | 471 | 58.8 | 9.2 |
9 | Fitzpatrick
MIA |
73.7 | 311 | 38.1 | 5.6 |
10 | Carr
LV |
73.6 | 417 | 54.4 | 4.8 |
This is starting to look better! However, since we stacked it, the rows are very tall, a bit too tall in my opinion. We can use line-height
inside the <div>
now to decrease the vertical space between our words.
ex_tab %>%
cols_merge(
columns = vars(last_name, team)
) %>%
text_transform(
locations = cells_body(
columns = vars(last_name)
),
fn = function(x){
name <- word(x, 1)
team <- word(x, -1)
glue::glue(
"<div style='line-height:10px'><span style='font-weight:bold;font-variant:small-caps;font-size:14px'>{name}</div>
<div style='line-height:12px'><span style ='font-weight:bold;color:grey;font-size:10px'>{team}</span></div>"
)
}
) %>%
tab_options(
data_row.padding = px(5),
)
rank | last_name | qbr_total | qb_plays | pass | run |
---|---|---|---|---|---|
1 | Mahomes
KC |
86.1 | 513 | 91.2 | 13.3 |
2 | Rodgers
GB |
85.1 | 433 | 69.2 | 6.3 |
3 | Brees
NO |
81.1 | 328 | 53.6 | 1.0 |
4 | Prescott
DAL |
79.0 | 263 | 31.2 | 4.9 |
5 | Tannehill
TEN |
76.7 | 413 | 48.9 | 11.7 |
6 | Allen
BUF |
75.4 | 513 | 72.2 | 9.4 |
7 | Wilson
SEA |
74.9 | 514 | 68.3 | 5.4 |
8 | Watson
HOU |
74.2 | 471 | 58.8 | 9.2 |
9 | Fitzpatrick
MIA |
73.7 | 311 | 38.1 | 5.6 |
10 | Carr
LV |
73.6 | 417 | 54.4 | 4.8 |
While we did that ALL within gt
, we could also have made similar changes by writing some HTML with functions inside mutate
ahead of sending it to gt
!
# function to incorporate player name + team
combine_word <- function(name, team){
glue::glue(
"<div style='line-height:10px'><span style='font-weight:bold;font-variant:small-caps;font-size:14px'>{name}</div>
<div style='line-height:12px'><span style ='font-weight:bold;color:grey;font-size:10px'>{team}</span></div>"
)
}
nfl_qbr %>%
select(rank, short_name, team, qbr_total, qb_plays, pass, run) %>%
mutate(
combo = combine_word(short_name, team),
combo = map(combo, gt::html)
) %>%
select(rank, combo, everything(), -short_name, -team) %>%
gt() %>%
cols_align(
align = "left",
columns = vars(combo)
) %>%
tab_options(
data_row.padding = px(5)
)
rank | combo | qbr_total | qb_plays | pass | run |
---|---|---|---|---|---|
1 | P. Mahomes
KC |
86.1 | 513 | 91.2 | 13.3 |
2 | A. Rodgers
GB |
85.1 | 433 | 69.2 | 6.3 |
3 | D. Brees
NO |
81.1 | 328 | 53.6 | 1.0 |
4 | D. Prescott
DAL |
79.0 | 263 | 31.2 | 4.9 |
5 | R. Tannehill
TEN |
76.7 | 413 | 48.9 | 11.7 |
6 | J. Allen
BUF |
75.4 | 513 | 72.2 | 9.4 |
7 | R. Wilson
SEA |
74.9 | 514 | 68.3 | 5.4 |
8 | D. Watson
HOU |
74.2 | 471 | 58.8 | 9.2 |
9 | R. Fitzpatrick
MIA |
73.7 | 311 | 38.1 | 5.6 |
10 | D. Carr
LV |
73.6 | 417 | 54.4 | 4.8 |
So that’s really cool and allows you to do some creative things with HTML-based content. What else can we do with HTML?
kableExtra
integrationThe fantastic kableExtra
package has some sparkline-esque graphing capabilities that export as SVG, meaning they can be integrated into HTML.
Note that while I love gt
, kableExtra
is again a great package in it’s own right and has more mature LaTeX integration today. If you REALLY have to use PDF/LaTex, it’s a great choice today.
kableExtra
approaches inline plots with the spec_plot()
family of functions.
kableExtra
exampleHere’s a quick example from kableExtra
, which can be adapted to work in gt
, mainly incorporating an inline boxplot into the table.
kableExtra
method, adapted from the great guide by Hao Zhu.
# first split the data by cylinders
mpg_list <- split(mtcars$mpg, mtcars$cyl)
mpg_list
$`4`
[1] 22.8 24.4 22.8 32.4 30.4 33.9 21.5 27.3 26.0 30.4 21.4
$`6`
[1] 21.0 21.0 21.4 18.1 19.2 17.8 19.7
$`8`
[1] 18.7 14.3 16.4 17.3 15.2 10.4 10.4 14.7 15.5 15.2 13.3 19.2 15.8
[14] 15.0
# pipe the
data.frame(
cyl = c(4,6,8),
boxplot = ""
) %>%
kbl(booktabs = TRUE) %>%
kable_paper(full_width = FALSE) %>%
column_spec(2, image = spec_boxplot(mpg_list, width = 300, height = 70))
cyl | boxplot |
---|---|
4 | |
6 | |
8 |
gt
+ kableExtra
We can adapt a similar idea for gt
, here we are using mutate
calls ahead of time to prep the data. Here we are going to keep all the data in a pipe, rather than having to split
it and reference a dataset external to our table. We can essentially nest the same mpg
column by group, keeping it in a single tibble
this time. As an aside, note that you can embed ANY ggplot
into gt
with gt::ggplot_image()
, but the ggplot_image()
method is quite a bit slower as of today. If you need the full power of ggplot
it’s totally worth it, but if you’re just adding sparklines I’m a big fan of kableExtra::spec_plot()
.
mtcars %>%
group_by(cyl) %>%
summarize(data = list(mpg), .groups = "drop")
# A tibble: 3 x 2
cyl data
<dbl> <list>
1 4 <dbl [11]>
2 6 <dbl [7]>
3 8 <dbl [14]>
Then we can create a range to set baselines for MPG, and then use kableExtra::spec_plot()
to embed an inline sparkline. Note we have to use purrr::map()
here to apply the function iteratively across each row.
mpg_rng <- range(mtcars$mpg)
mtcars %>%
group_by(cyl) %>%
summarize(data = list(mpg), .groups = "drop") %>%
mutate(
plot = map(data, ~spec_plot(.x, ylim = mpg_rng, same_lim = TRUE, width = 300, height = 70)),
plot = map(plot, "svg_text"),
plot = map(plot, gt::html)
) %>%
select(-data) %>%
gt()
cyl | plot |
---|---|
4 | |
6 | |
8 |
Now that I’ve showed that it’s possible, what are we actually doing? kableExtra::spec_plot()
creates a plot in base R, and then returns it as either svg or pdf, which means it can be compatible with either HTML or LaTeX. Remember the mpg_list
we created by splitting the mpg
column into a list of vectors by cyl
?
mpg_list %>% str()
List of 3
$ 4: num [1:11] 22.8 24.4 22.8 32.4 30.4 33.9 21.5 27.3 26 30.4 ...
$ 6: num [1:7] 21 21 21.4 18.1 19.2 17.8 19.7
$ 8: num [1:14] 18.7 14.3 16.4 17.3 15.2 10.4 10.4 14.7 15.5 15.2 ...
We can create plots for each cyl
and then pull the cyl == 4
plot and look at it’s structure.
List of 7
$ path : chr(0)
$ dev : chr "svg"
$ type : chr "line"
$ width : num 200
$ height : num 50
$ res : num 300
$ svg_text: chr "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www."| __truncated__
- attr(*, "class")= chr [1:2] "kableExtraInlinePlots" "list"
We see that it returns a list object, with mostly metadata about what parameters were passed to the function. The part we really want is the svg_text
since that has the xml
code to generate our inline plot. We can pull out the svg_text
list item from our list of lists by calling map("svg_text")
. Now we can see each of the svg-plots, one for each cylinder group!
List of 3
$ 4: chr "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www."| __truncated__
$ 6: chr "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www."| __truncated__
$ 8: chr "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www."| __truncated__
So now that we have the specific item of interest we need to let gt
“know” to treat this as HTML and not just a random character string. We can call map()
one more time and apply the gt::html()
function to each svg plot.
List of 3
$ 4: 'html' chr "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www."| __truncated__
..- attr(*, "html")= logi TRUE
$ 6: 'html' chr "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www."| __truncated__
..- attr(*, "html")= logi TRUE
$ 8: 'html' chr "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www."| __truncated__
..- attr(*, "html")= logi TRUE
And that’s why the following code works:
- Group by cylinder
- Summarize down to a list-column of the respective MPG column by cylinder
- Create the spec_plot
object
- Extract the svg_text
- Recognize the svg_text
as HTML
- gt
takes the HTML and parses it
mtcars %>%
group_by(cyl) %>%
summarize(data = list(mpg), .groups = "drop") %>%
mutate(
plot = map(data, ~spec_plot(.x, ylim = mpg_rng, same_lim = TRUE, width = 300, height = 70)),
plot = map(plot, "svg_text"),
plot = map(plot, gt::html)
) %>%
select(-data) %>%
gt()
cyl | plot |
---|---|
4 | |
6 | |
8 |
gt
While that works just fine, it assumes that you create the content ahead of time, before incorporating it into gt
. However, you can also approach it from within gt
itself.
For the next one, I have a more general function to use.
The custom function gt_plot()
:
- Takes the table data from gt
- You specify a specific column
- You specify external data to plot
- Specify what type of plot
- Optionally pass additional arguments to spec_plot
with ...
gt_plot <- function(table_data, column, plot_data, plot_fun, ...){
text_transform(
table_data,
# note the use of {{}} here - this is tidy eval
# that allows you to indicate specific columns
locations = cells_body(columns = vars({{column}})),
fn = function(x){
plot <- map(plot_data, plot_fun, width = 300, height = 70, same_lim = TRUE, ...)
plot_svg <- map(plot, "svg_text")
map(plot_svg, gt::html)
}
)
}
Note that again, my table “data” is pretty minimal, and I’ve got the data externally as our mpg_list
object we created earlier.
mpg_list %>% str()
List of 3
$ 4: num [1:11] 22.8 24.4 22.8 32.4 30.4 33.9 21.5 27.3 26 30.4 ...
$ 6: num [1:7] 21 21 21.4 18.1 19.2 17.8 19.7
$ 8: num [1:14] 18.7 14.3 16.4 17.3 15.2 10.4 10.4 14.7 15.5 15.2 ...
tibble(cyl = c(4,6,8), boxplot = "") %>%
gt() %>%
gt_plot(
column = boxplot, # column to create plot in
plot_data = mpg_list, # external data to reference
plot_fun = spec_boxplot, # which plot fun
lim = mpg_rng # range applied
)
cyl | boxplot |
---|---|
4 | |
6 | |
8 |
We can quickly switch from a boxplot to a sparkline, just by changing the plot_fun
argument to spec_plot
. Also since I passed ellipses (...
) to the spec_plot()
function we can also use some additional arguments to change the line-color to black, and make the max/min points to be a bit larger.
tibble(cyl = c(4,6,8), boxplot = "") %>%
gt() %>%
gt_plot(
column = boxplot, # column to create plot in
plot_data = mpg_list, # external data to reference
plot_fun = spec_plot, # which plot fun
ylim = mpg_rng, # range applied,
col = "black", # change color of line
cex = 5 # change size of points
)
cyl | boxplot |
---|---|
4 | |
6 | |
8 |
This works with all the kableExtra
inline plot functions! Note that we are just varying the ylim
on the line/points 1 vs 2, where the mpg_line1/mpg_points1 share a common y-axis, and line2/points2 have their own y-axis.
tibble(
cyl = c(4,6,8),
boxplot = "", mpg_hist = "", mpg_line1 = "",
mpg_line2 = "", mpg_points1 = "",
mpg_points2 = "", mpg_poly = ""
) %>%
gt() %>%
gt_plot(column = boxplot, plot_data = mpg_list, plot_fun = spec_boxplot, lim = mpg_rng) %>%
gt_plot(column = mpg_hist, plot_data = mpg_list, plot_fun = spec_hist, lim = mpg_rng) %>%
gt_plot(column = mpg_line1, plot_data = mpg_list, plot_fun = spec_plot, ylim = mpg_rng) %>%
gt_plot(column = mpg_line2, plot_data = mpg_list, plot_fun = spec_plot) %>%
gt_plot(column = mpg_points1, plot_data = mpg_list, plot_fun = spec_plot, type = "p", ylim = mpg_rng, cex = 4) %>%
gt_plot(column = mpg_points2, plot_data = mpg_list, plot_fun = spec_plot, type = "p", cex = 4) %>%
gt_plot(column = mpg_poly, plot_data = mpg_list, plot_fun = spec_plot, polymin = 5, ylim = mpg_rng)
cyl | boxplot | mpg_hist | mpg_line1 | mpg_line2 | mpg_points1 | mpg_points2 | mpg_poly |
---|---|---|---|---|---|---|---|
4 | |||||||
6 | |||||||
8 |
OK so we now have a function, but we’re referencing an external data object, rather than data within the “table” itself - not ideal!
Can we just use our group_by
+ summarize
as list from before without any changes? (Spoiler = nope
)
# doesn't work
mtcars %>%
group_by(cyl) %>%
summarize(data = list(mpg), .groups = "drop") %>%
gt() %>%
text_transform(
locations = cells_body(columns = vars(data)),
fn = function(x){
plot = map(x, ~spec_plot(.x, ylim = mpg_rng, same_lim = TRUE, width = 300, height = 70))
plot = map(plot, "svg_text")
plot = map(plot, gt::html)
}
)
cyl | data |
---|---|
4 | |
6 | |
8 |
Nope - but it does give us a decent error message!
1: In xy.coords(x, y, xlabel, ylabel, log) : NAs introduced by coercion
2: In which.min(y) : NAs introduced by coercion
3: In which.max(y) : NAs introduced by coercion
There seems to be a type conversion - NAs are being returned where we expect numeric data to create the x-y coordinates for the plot. Let’s dive a bit closer into what happens when we call text_transform()
. I’m calling str()
inside our text_transform()
now to expose what the data itself looks like.
# doesn't work
mtcars %>%
group_by(cyl) %>%
summarize(mpg_data = list(mpg), .groups = "drop") %>%
gt() %>%
text_transform(
locations = cells_body(columns = vars(mpg_data)),
fn = function(x){
str(x)
})
List of 3
$ : chr "22.8, 24.4, 22.8, 32.4, 30.4, 33.9, 21.5, 27.3, 26.0, 30.4, 21.4"
$ : chr "21.0, 21.0, 21.4, 18.1, 19.2, 17.8, 19.7"
$ : chr "18.7, 14.3, 16.4, 17.3, 15.2, 10.4, 10.4, 14.7, 15.5, 15.2, 13.3, 19.2, 15.8, 15.0"
Error: Assigned data `*vtmp*` must be compatible with existing data.
x Existing data has 3 rows.
x Assigned data has 0 rows.
ℹ Only vectors of size 1 are recycled.
This tells us something interesting! It’s combined all the vectors into a character string separated by commas. No wonder our graph can’t understand its xy coords, it is passed as one long text string!
Now if we’re tricky, we can get at the guts
of gt
since it’s just a list object. There’s quite a bit there inside the gt
object, but the first list item is arguably the most important! We have the raw data as _data
!
mtcars %>%
group_by(cyl) %>%
summarize(mpg_data = list(mpg), .groups = "drop") %>%
gt() %>%
str(max.level = 1)
List of 16
$ _data : tibble [3 × 2] (S3: tbl_df/tbl/data.frame)
$ _boxhead : tibble [2 × 6] (S3: tbl_df/tbl/data.frame)
$ _stub_df : tibble [3 × 3] (S3: tbl_df/tbl/data.frame)
$ _row_groups : chr(0)
$ _stub_others : chr NA
$ _heading :List of 2
$ _spanners : tibble [0 × 4] (S3: tbl_df/tbl/data.frame)
$ _stubhead :List of 1
$ _footnotes : tibble [0 × 7] (S3: tbl_df/tbl/data.frame)
$ _source_notes: list()
$ _formats : list()
$ _styles : tibble [0 × 7] (S3: tbl_df/tbl/data.frame)
$ _summary : list()
$ _options : tibble [133 × 5] (S3: tbl_df/tbl/data.frame)
$ _transforms : list()
$ _has_built : logi FALSE
- attr(*, "class")= chr [1:2] "gt_tbl" "list"
We can pluck()
the raw underlying data itself from gt
, extract the mpg_data
column, and could work with it in our function.
mtcars %>%
group_by(cyl) %>%
summarize(mpg_data = list(as.double(mpg)), .groups = "drop") %>%
gt() %>%
pluck("_data", "mpg_data") %>%
str()
List of 3
$ : num [1:11] 22.8 24.4 22.8 32.4 30.4 33.9 21.5 27.3 26 30.4 ...
$ : num [1:7] 21 21 21.4 18.1 19.2 17.8 19.7
$ : num [1:14] 18.7 14.3 16.4 17.3 15.2 10.4 10.4 14.7 15.5 15.2 ...
So let’s try it out! Remember, we’re using pluck()
to get the dataframe from gt
’s list object, and then pulling out the mpg_data
column from it.
# works now
mtcars %>%
group_by(cyl) %>%
summarize(mpg_data = list(mpg), .groups = "drop") %>%
gt() %>%
text_transform(
locations = cells_body(columns = vars(mpg_data)),
fn = function(x){
data_in = pluck(., "_data", "mpg_data")
plot = map(data_in, ~spec_plot(.x, ylim = mpg_rng, same_lim = TRUE, width = 300, height = 70))
plot = map_chr(plot, "svg_text")
})
cyl | mpg_data |
---|---|
4 | |
6 | |
8 |
That worked beautifully!
An alternative that doesn’t require going into the gt
object itself and coerces the character string back into numeric. This is a bit clunkier, but totally possible.
# WORKS
mtcars %>%
group_by(cyl) %>%
summarize(mpg_data = list(as.double(mpg)), .groups = "drop") %>%
gt() %>%
text_transform(
locations = cells_body(columns = vars(mpg_data)),
fn = function(x) {
# split the strings at each comma
split_data <- str_split(x, ", ")
# convert to type double
data <- map(split_data, as.double)
# create the plot
plot <- map(data, ~ spec_plot(.x, ylim = mpg_rng, same_lim = TRUE, width = 300, height = 70))
# extract the svg item
map(plot, "svg_text")
}
)
cyl | mpg_data |
---|---|
4 | |
6 | |
8 |
Ok so we’ve shown that it’s possible to do that either way, so let’s rewrite our function!
gt_plot <- function(table_data, plot_col, data_col, plot_fun, ...){
# save the data extract ahead of time
# to be used in our anonymous function below
data_in = pluck(table_data, "_data", data_col)
text_transform(
table_data,
# note the use of {{}} here - this is tidy eval
# that allows you to indicate specific columns
locations = cells_body(columns = vars({{plot_col}})),
fn = function(x){
plot <- map(data_in, plot_fun, width = 300, height = 70, same_lim = FALSE, ...)
plot_svg <- map(plot, "svg_text")
map(plot_svg, gt::html)
}
)
}
This function will now work exactly as expected with the grouped list data columns!
# works!
mtcars %>%
group_by(cyl) %>%
summarize(mpg_data = list(mpg), .groups = "drop") %>%
gt() %>%
# note you can leave mpg_data unquoted for the tidyeval
# but have to quote mpg_data for the pluck
gt_plot(mpg_data, "mpg_data", plot_fun = spec_plot)
cyl | mpg_data |
---|---|
4 | |
6 | |
8 |
sparklines
So the embedded sparklines as shown above are fantastic, quick and robust, but they’re static. Since we’re focusing on HTML content, why don’t we also see if we can get javascript enabled interactivity?
Quick example of this working below, but note you need to call sparkline(0)
somewhere ahead of time in your RMarkdown doc to load the javascript library dependency. Also, if you try to view this interactively it will look like it failed and didn’t pass anything through, but it will work when the RMarkdown is knit and the JavaScript can be called properly.
tibble(
var = c("mpg", "wt"),
sparkline1 = "",
sparkline2 = "",
box = ""
) %>%
gt() %>%
text_transform(
locations = cells_body(vars(sparkline1)),
fn = function(x){
sparkline <- map(list(mtcars$mpg, mtcars$wt), ~spk_chr(values = .x, chartRangeMin = 0))
map(sparkline, gt::html)
}
) %>%
text_transform(
locations = cells_body(vars(sparkline2)),
fn = function(x){
sparkline <- map(list(mtcars$mpg, mtcars$wt), ~spk_chr(values = .x, type = "bar", chartRangeMin = 0))
map(sparkline, gt::html)
}
) %>%
text_transform(
locations = cells_body(vars(box)),
fn = function(x){
sparkline <- map(list(mtcars$mpg, mtcars$wt), ~spk_chr(values = .x, type = "box", chartRangeMin = 0))
map(sparkline, gt::html)
}
)
var | sparkline1 | sparkline2 | box |
---|---|---|---|
mpg | |||
wt |
While we’re likely to only be using this in a table once per each , I do want to try and create a function so that we don’t have to re-write these each time and could potentially roll it into a package.
gt_spark <- function(table_data, plot_col, data_col){
# save the data extract ahead of time
# to be used in our anonymous function below
data_in = pluck(table_data, "_data", data_col)
text_transform(
table_data,
# note the use of {{}} here - this is tidy eval
# that allows you to indicate specific columns
locations = cells_body(columns = vars({{plot_col}})),
fn = function(x){
sparkline_plot <- map(
data_in,
~spk_chr(values = .x, chartRangeMin = 0)
)
map(sparkline_plot, gt::html)
}
)
}
We can then apply the function to work very succinctly, referencing only the internal list-column data.
# works!
mtcars %>%
group_by(cyl) %>%
summarize(mpg_data = list(mpg), .groups = "drop") %>%
gt() %>%
# note you can leave mpg_data unquoted for the tidyeval
# but have to quote mpg_data for the pluck
gt_spark(mpg_data, "mpg_data")
cyl | mpg_data |
---|---|
4 | |
6 | |
8 |
You can also make forest-plot like tables in gt
, note that this code is taken essentially verbatim from kableExtra
’s documentation, just adapted to work in gt
.
coef_table <- data.frame(
Variables = c("var 1", "var 2", "var 3"),
Coefficients = c(1.6, 0.2, -2.0),
Conf.Lower = c(1.3, -0.4, -2.5),
Conf.Higher = c(1.9, 0.6, -1.4)
)
tibble(
Variable = coef_table$Variables,
) %>%
mutate(
image = spec_pointrange(
x = coef_table$Coefficients,
xmin = coef_table$Conf.Lower,
xmax = coef_table$Conf.Higher,
vline = 0,
width = 250,
cex = .75,
col = "black",
pch = 16
)
) %>%
mutate(
image = map(image, "svg_text"),
image = map(image, ~gt::html(as.character(.x)))
) %>%
gt()
Variable | image |
---|---|
var 1 | |
var 2 | |
var 3 |
We can show a bit more robust example from a recent question by [Silvia Canelón - @spcanelon](https://twitter.com/spcanelon/status/1320832482334396416?s=21)
coef_table <- tibble(
group = c(
"",
rep("Sex", 2),
rep("Age", 4),
rep("Body-Mass index", 2),
rep("Race", 3),
rep("Baseline statin treatment", 2),
rep("Intensity of statin treatment", 2),
rep("Metabolic disease", 3),
rep("Renal function", 3)
),
subgroup = c(
"All Patients",
"Male", "Female",
"<65 yr", ">= 65 yr", "<75 yr", ">=75 yr",
"<=Median", ">Median",
"White", "Black", "Other",
"Yes", "No",
"High", "Not high",
"Diabetes", "Metabolic syndrome", "Neither",
"Normal", "Mild impairment", "Moderate impairment"
),
Inclisiran = c(
781, 535,246,297,484,638,143,394,387,653,110,18,701,80,538,243,371,195,215,395,269,113
),
Placebo = c(
780,548,232,333,447,649,131,385,394,685,87,8,692,88,546,234,331,207,242,410,260,107
),
coefficients = c(-60,-55,-68,-58,-55,-57,-58,-55,-48,-58,-57,-49,-44,-58,-55,-57,-54,-52,-54,-53, -54,-52)
) %>%
mutate(
conf_range = runif(22, min = 5, max = 10),
conf_lower = coefficients - conf_range,
conf_higher = coefficients + conf_range
) %>%
mutate(
image = spec_pointrange(
x = coefficients,
xmin = conf_lower,
xmax = conf_higher,
same_lim = TRUE,
lim = c(-100, 25),
vline = 0,
width = 550,
cex = .75,
col = "black"
)
)
Here’s the code to create a quick table with a zero-indicated line, and some randomly generated “variation”.
coef_table %>%
select(-coefficients, -contains("conf")) %>%
mutate(
image = map(image, "svg_text"),
image = map(image, ~gt::html(as.character(.x)))
) %>%
select(group:Placebo, pct_diff = image) %>%
gt(
groupname_col = "group",
rowname_col = "subgroup"
) %>%
opt_row_striping() %>%
tab_options(
data_row.padding = px(3)
)
Inclisiran | Placebo | pct_diff | |
---|---|---|---|
All Patients | 781 | 780 | |
Sex | |||
Male | 535 | 548 | |
Female | 246 | 232 | |
Age | |||
<65 yr | 297 | 333 | |
>= 65 yr | 484 | 447 | |
<75 yr | 638 | 649 | |
>=75 yr | 143 | 131 | |
Body-Mass index | |||
<=Median | 394 | 385 | |
>Median | 387 | 394 | |
Race | |||
White | 653 | 685 | |
Black | 110 | 87 | |
Other | 18 | 8 | |
Baseline statin treatment | |||
Yes | 701 | 692 | |
No | 80 | 88 | |
Intensity of statin treatment | |||
High | 538 | 546 | |
Not high | 243 | 234 | |
Metabolic disease | |||
Diabetes | 371 | 331 | |
Metabolic syndrome | 195 | 207 | |
Neither | 215 | 242 | |
Renal function | |||
Normal | 395 | 410 | |
Mild impairment | 269 | 260 | |
Moderate impairment | 113 | 107 |
For the next section, I’ll be showing some functions that are mostly adapted from Greg Lin’s fantastic examples for the reactable
package Cookbook. I love reactable
, but want to show how some of the same ideas can translate in to mostly static tables as well. Note that some of the tags$
, div
, etc are from the htmltools
package, and you can generally write your own HTML by hand if you wanted.
# note you could use ANY font-awesome logo
# https://fontawesome.com/cheatsheet
rating_stars <- function(rating, max_rating = 5) {
rounded_rating <- floor(rating + 0.5) # always round up
stars <- lapply(seq_len(max_rating), function(i) {
if (i <= rounded_rating) fontawesome::fa("star", fill= "orange") else fontawesome::fa("star", fill= "grey")
})
label <- sprintf("%s out of %s", rating, max_rating)
div_out <- div(title = label, "aria-label" = label, role = "img", stars)
as.character(div_out) %>%
gt::html()
}
fontawesome
package for inline icons
rank_chg <- function(change_dir){
if (change_dir == "increase") {
logo_out <- fontawesome::fa("arrow-up", fill = "blue")
} else if (change_dir == "decrease"){
logo_out <- fontawesome::fa("arrow-down", fill = "red")
}
logo_out %>%
as.character() %>%
gt::html()
}
add_cyl_color <- function(cyl){
add_color <- if (cyl == 4) {
"background: hsl(116, 60%, 90%); color: hsl(116, 30%, 25%);"
} else if (cyl == 6) {
"background: hsl(230, 70%, 90%); color: hsl(230, 45%, 30%);"
} else if (cyl == 8) {
"background: hsl(350, 70%, 90%); color: hsl(350, 45%, 30%);"
}
div_out <- htmltools::div(
style = paste(
"display: inline-block; padding: 2px 12px; border-radius: 15px; font-weight: 600; font-size: 12px;",
add_color
),
paste(cyl, "Cylinders")
)
as.character(div_out) %>%
gt::html()
}
bar_chart <- function(value, color = "red"){
glue::glue("<span style=\"display: inline-block; direction: ltr; border-radius: 4px; padding-right: 2px; background-color: {color}; color: {color}; width: {value}%\"> </span>") %>%
as.character() %>%
gt::html()
}
All of these examples can be used in one example table! I’ve also added a HTML example of a hyperlink for the “data source” which links to the gt
page for HTML content 😄. So now we have:
- Tooltips
- Embedded icons/font-awesome logos
- Badges + colors
- HTML-only bar charts
- Hyperlinks
- Expandable Tabke Key as “Details” with a HTML <details>
tag
set.seed(377)
mtcars %>%
tibble() %>%
select(1:4) %>%
sample_n(size = 6) %>%
mutate(
rank_change = sample(c("increase", "decrease"), size = 6, replace = TRUE),
rank_change = map(rank_change, rank_chg)
) %>%
mutate(
rating = sample(1:5, size = 6, replace = TRUE),
rating = map(rating, rating_stars)
) %>%
mutate(
cylinder = map(cyl, add_cyl_color)
) %>%
mutate(
mpg_plot = mpg/max(mpg) * 100,
mpg_plot = map(mpg_plot, ~bar_chart(value = .x, color = "lightblue"))
) %>%
gt() %>%
cols_align(
align = "left",
columns = vars(mpg_plot)
) %>%
cols_label(
mpg = gt::html(as.character(with_tooltip("MPG", "Miles per Gallon")))
) %>%
tab_source_note(
source_note = html(
htmltools::tags$a(
href = "https://gt.rstudio.com/reference/md.html",
target = "_blank",
"Data Source"
) %>%
as.character()
)
) %>%
tab_source_note(
source_note = html(
"<details><h3 style='font-face:bold'>Table Key</h3><div>MPG: Miles Per Gallon</div><div>Cyl: Cylinders</div><div>disp: Displacement</div><div>hp: Horsepower</div><div>rank_change: Rank Change</div><div>rating: Rating</div></details>"
)
) %>%
tab_options(
data_row.padding = px(5)
)
MPG | cyl | disp | hp | rank_change | rating | cylinder | mpg_plot |
---|---|---|---|---|---|---|---|
15.5 | 8 | 318.0 | 150 | 8 Cylinders |
|||
14.3 | 8 | 360.0 | 245 | 8 Cylinders |
|||
21.0 | 6 | 160.0 | 110 | 6 Cylinders |
|||
10.4 | 8 | 472.0 | 205 | 8 Cylinders |
|||
26.0 | 4 | 120.3 | 91 | 4 Cylinders |
|||
15.0 | 8 | 301.0 | 335 | 8 Cylinders |
|||
Data Source | |||||||
Table KeyMPG: Miles Per Gallon Cyl: Cylinders disp: Displacement hp: Horsepower rank_change: Rank Change rating: Rating |
Let’s put all the things we’ve learned together into a publication-quality table, we’ll collect some QBR data to use.
# use espnscrapeR to get NFL standings + QBR ratings
nfl_qbr <- get_nfl_qbr(2020)
nfl_standings <- get_nfl_standings(2020)
# also get weekly for embedded plot
qbr_weekly <- crossing(season = 2020, week = 1:8) %>%
pmap_dfr(.f = get_nfl_qbr)
Then we’ll summarise the data to prep for an embedded plot, and join together our NFL standings, QBR, and weekly QBR.
qbr_match <- qbr_weekly %>%
filter(short_name %in% nfl_qbr$short_name) %>%
group_by(short_name, team) %>%
summarise(qbr_weekly = list(qbr_total), .groups = "drop",
qbr = mean(qbr_total),
qbr_sd = sd(qbr_total),
plays = sum(qb_plays),
pass = mean(pass),
run = mean(run),
head = unique(headshot_href),
n = n()) %>%
arrange(desc(qbr)) %>%
filter(n >= 7)
# clean up the data a bit and combine
tab_df <- qbr_match %>%
left_join(nfl_standings, by = c("team" = "abb_name")) %>%
select(short_name, team, head, qbr_weekly:run, wins, losses, points_for) %>%
mutate(wl = glue("{wins}-{losses}")) %>%
select(-wins, -losses)
tab_df
# A tibble: 23 x 11
short_name team head qbr_weekly qbr qbr_sd plays pass run
<chr> <chr> <chr> <list> <dbl> <dbl> <dbl> <dbl> <dbl>
1 R. Wilson SEA http… <dbl [7]> 82.4 6.62 328 6.09 1.17
2 P. Mahomes KC http… <dbl [8]> 78.6 16.4 347 6.65 1.29
3 D. Brees NO http… <dbl [7]> 78.2 11.3 280 5.69 0.171
4 A. Rodgers GB http… <dbl [7]> 77.4 28.0 285 5.89 0.586
5 J. Allen BUF http… <dbl [8]> 76.5 16.4 362 5.91 1.21
6 R. Tanneh… TEN http… <dbl [7]> 74.5 18.1 284 5.19 1.13
7 D. Carr LV http… <dbl [7]> 72.6 16.2 284 4.91 0.357
8 M. Ryan ATL http… <dbl [8]> 70.6 26.2 370 4.6 0.662
9 K. Murray ARI http… <dbl [7]> 69.4 16.8 340 3.41 2.69
10 D. Watson HOU http… <dbl [7]> 67.7 19.3 305 4.16 0.186
# … with 13 more rows, and 2 more variables: points_for <dbl>,
# wl <glue>
# calc rank change
qbr_rnk_chg <- qbr_weekly %>%
mutate(game_week = as.integer(game_week)) %>%
group_by(short_name) %>%
mutate(mean_qbr = mean(qbr_total)) %>%
ungroup() %>%
select(game_week, rank, short_name, qbr_total, mean_qbr) %>%
filter(game_week != max(game_week)) %>%
filter(short_name %in% nfl_qbr$short_name) %>%
group_by(short_name) %>%
summarize(prev_qbr = mean(qbr_total), mean_qbr = unique(mean_qbr)) %>%
mutate(
prev_week = rank(-prev_qbr),
rank = rank(-mean_qbr)
) %>%
mutate(rank_chg = prev_week-rank) %>%
ungroup() %>%
arrange(desc(mean_qbr)) %>%
select(short_name, qbr = mean_qbr, rank_chg, rank)
qbr_rnk_chg
# A tibble: 31 x 4
short_name qbr rank_chg rank
<chr> <dbl> <dbl> <dbl>
1 R. Wilson 82.4 0 1
2 P. Mahomes 78.6 4 2
3 D. Brees 78.2 1 3
4 A. Rodgers 77.4 1 4
5 J. Allen 76.5 -3 5
6 R. Tannehill 74.5 -3 6
7 D. Prescott 74.2 1 7
8 J. Herbert 73.9 3 8
9 R. Fitzpatrick 73.0 0 9
10 D. Carr 72.6 -3 10
# … with 21 more rows
We can then combine the player name, team, and win-loss record into one set of “data” presented with some HTML formatting.
combine_word <- function(name, team, wl){
glue::glue(
"<div style='line-height:10px'><span style='font-weight:bold;font-variant:small-caps;font-size:14px'>{name}</div>
<div style='line-height:12px'><span style ='font-weight:bold;color:grey;font-size:10px'>{team} {wl}</span></div>"
)
}
combo_df <- tab_df %>%
left_join(qbr_rnk_chg, by = c("short_name", "qbr")) %>%
select(rank, rank_chg, short_name:wl) %>%
mutate(
rank = row_number(),
combo = combine_word(short_name, team, wl),
combo = map(combo, gt::html)
) %>%
select(rank, rank_chg, head, combo, qbr, qbr_weekly, plays, points_for)
combo_df
# A tibble: 23 x 8
rank rank_chg head combo qbr qbr_weekly plays points_for
<int> <dbl> <chr> <lis> <dbl> <list> <dbl> <dbl>
1 1 0 https://a.e… <htm… 82.4 <dbl [7]> 328 274
2 2 4 https://a.e… <htm… 78.6 <dbl [8]> 347 286
3 3 1 https://a.e… <htm… 78.2 <dbl [7]> 280 206
4 4 1 https://a.e… <htm… 77.4 <dbl [7]> 285 253
5 5 -3 https://a.e… <htm… 76.5 <dbl [8]> 362 242
6 6 -3 https://a.e… <htm… 74.5 <dbl [7]> 284 232
7 7 -3 https://a.e… <htm… 72.6 <dbl [7]> 284 218
8 8 3 https://a.e… <htm… 70.6 <dbl [8]> 370 243
9 9 1 https://a.e… <htm… 69.4 <dbl [7]> 340 234
10 10 3 https://a.e… <htm… 67.7 <dbl [7]> 305 193
# … with 13 more rows
final_table <- combo_df %>%
gt() %>%
cols_align(
align = "left",
columns = vars(combo)
) %>%
tab_options(
data_row.padding = px(2)
) %>%
text_transform(
locations = cells_body(columns = vars(head)),
fn = function(x){
gt::web_image(x)
}
) %>%
text_transform(
locations = cells_body(columns = vars(rank_chg)),
fn = function(x){
rank_chg <- as.integer(x)
choose_logo <-function(x){
if (x == 0){
gt::html(fontawesome::fa("equals", fill = "grey"))
} else if (x > 0){
gt::html(glue::glue("<span style='color:#1134A6;font-face:bold;font-size:10px;'>{x}</span>"), fontawesome::fa("arrow-up", fill = "#1134A6"))
} else if (x < 0) {
gt::html(glue::glue("<span style='color:#DA2A2A;font-face:bold;font-size:10px;'>{x}</span>"), fontawesome::fa("arrow-down", fill = "#DA2A2A"))
}
}
map(rank_chg, choose_logo)
}
) %>%
fmt_number(
columns = vars(qbr),
decimals = 1
) %>%
tab_style(
style = cell_text(weight = "bold"),
locations = cells_column_labels(TRUE)
) %>%
cols_label(
rank = "RK",
combo = "",
head = "QB",
qbr = "QBR",
plays = "PLAYS",
points_for = "PF",
qbr_weekly = "WEEKLY",
rank_chg = ""
) %>%
gt_spark(qbr_weekly, "qbr_weekly") %>%
espnscrapeR::gt_theme_espn() %>%
tab_source_note(
source_note = gt::html(
htmltools::tags$a(
href = "https://www.espn.com/nfl/qbr",
target = "_blank",
"Data: ESPN"
) %>%
as.character()
)
) %>%
cols_align(
"left",
columns = vars(qbr_weekly)
) %>%
cols_width(
vars(rank) ~ px(25),
vars(rank_chg) ~ px(35),
vars(head) ~ px(50),
vars(combo) ~ px(115),
vars(qbr) ~ px(35),
vars(plays) ~ px(35),
vars(points_for) ~ px(35),
vars(qbr_weekly) ~ px(75)
) %>%
tab_header(
title = gt::html("<h3>NFL QBR through Week 8</h3>")
) %>%
tab_options(
table.width = px(480),
data_row.padding = px(4)
)
final_table
NFL QBR through Week 8 |
|||||||
---|---|---|---|---|---|---|---|
RK | QB | QBR | WEEKLY | PLAYS | PF | ||
1 | ![]() |
R. Wilson
SEA 6-2 |
82.4 | 328 | 274 | ||
2 | 4 | ![]() |
P. Mahomes
KC 8-1 |
78.6 | 347 | 286 | |
3 | 1 | ![]() |
D. Brees
NO 5-2 |
78.2 | 280 | 206 | |
4 | 1 | ![]() |
A. Rodgers
GB 6-2 |
77.4 | 285 | 253 | |
5 | -3 | ![]() |
J. Allen
BUF 7-2 |
76.5 | 362 | 242 | |
6 | -3 | ![]() |
R. Tannehill
TEN 6-2 |
74.5 | 284 | 232 | |
7 | -3 | ![]() |
D. Carr
LV 5-3 |
72.6 | 284 | 218 | |
8 | 3 | ![]() |
M. Ryan
ATL 3-6 |
70.6 | 370 | 243 | |
9 | 1 | ![]() |
K. Murray
ARI 5-3 |
69.4 | 340 | 234 | |
10 | 3 | ![]() |
D. Watson
HOU 2-6 |
67.7 | 305 | 193 | |
11 | 5 | ![]() |
T. Brady
TB 6-2 |
67.1 | 349 | 247 | |
12 | ![]() |
T. Bridgewater
CAR 3-6 |
64.7 | 329 | 210 | ||
13 | -4 | ![]() |
M. Stafford
DET 3-5 |
64.6 | 295 | 197 | |
14 | 4 | ![]() |
P. Rivers
IND 5-3 |
64.3 | 256 | 208 | |
15 | -8 | ![]() |
L. Jackson
BAL 6-2 |
63.4 | 282 | 227 | |
16 | -2 | ![]() |
B. Mayfield
CLE 5-3 |
63.4 | 271 | 206 | |
17 | ![]() |
D. Jones
NYG 2-7 |
61.8 | 346 | 168 | ||
18 | -3 | ![]() |
J. Goff
LAR 5-3 |
59.5 | 328 | 193 | |
19 | ![]() |
B. Roethlisberger
PIT 8-0 |
59.4 | 283 | 235 | ||
20 | ![]() |
J. Burrow
CIN 2-5 |
56.4 | 426 | 194 | ||
21 | 3 | ![]() |
K. Cousins
MIN 3-5 |
53.3 | 232 | 217 | |
22 | -1 | ![]() |
G. Minshew II
JAX 1-7 |
52.8 | 331 | 179 | |
23 | -1 | ![]() |
C. Wentz
PHI 3-4 |
49.3 | 407 | 186 | |
Data: ESPN |
So that’s all for now, but hopefully having this “cheatsheet” lets you go even further with all the possible creations you can make with a lot of gt
and a little bit of HTML!
For attribution, please cite this work as
Mock (2020, Oct. 31). The Mockup Blog: Embedding custom HTML in gt tables. Retrieved from https://themockup.blog/posts/2020-10-31-embedding-custom-features-in-gt-tables/
BibTeX citation
@misc{mock2020embedding, author = {Mock, Thomas}, title = {The Mockup Blog: Embedding custom HTML in gt tables}, url = {https://themockup.blog/posts/2020-10-31-embedding-custom-features-in-gt-tables/}, year = {2020} }