The Mockup Blog: Embedding custom HTML in gt tables

Thomas Mock

`gt` loves HTML

gt 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	Rodgers	Packers	84.4	608	98.4	9.3
2	Mahomes	Chiefs	82.9	710	116.1	19.1
3	Allen	Bills	81.7	729	112.1	13.0
4	Tannehill	Titans	78.3	594	68.2	22.1
5	Fitzpatrick	Dolphins	76.9	324	41.6	5.6
6	Brees	Saints	74.6	428	62.5	1.0
7	Jackson	Ravens	73.7	585	50.9	30.8
8	Wilson	Seahawks	73.5	716	88.6	9.1
9	Brady	Buccaneers	72.5	681	90.4	-3.1
10	Mayfield	Browns	72.2	597	76.9	3.4

More HTML!

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	Rodgers Packers	84.4	608	98.4	9.3
2	Mahomes Chiefs	82.9	710	116.1	19.1
3	Allen Bills	81.7	729	112.1	13.0
4	Tannehill Titans	78.3	594	68.2	22.1
5	Fitzpatrick Dolphins	76.9	324	41.6	5.6
6	Brees Saints	74.6	428	62.5	1.0
7	Jackson Ravens	73.7	585	50.9	30.8
8	Wilson Seahawks	73.5	716	88.6	9.1
9	Brady Buccaneers	72.5	681	90.4	-3.1
10	Mayfield Browns	72.2	597	76.9	3.4

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	Rodgers Packers	84.4	608	98.4	9.3
2	Mahomes Chiefs	82.9	710	116.1	19.1
3	Allen Bills	81.7	729	112.1	13.0
4	Tannehill Titans	78.3	594	68.2	22.1
5	Fitzpatrick Dolphins	76.9	324	41.6	5.6
6	Brees Saints	74.6	428	62.5	1.0
7	Jackson Ravens	73.7	585	50.9	30.8
8	Wilson Seahawks	73.5	716	88.6	9.1
9	Brady Buccaneers	72.5	681	90.4	-3.1
10	Mayfield Browns	72.2	597	76.9	3.4

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	Rodgers Packers	84.4	608	98.4	9.3
2	Mahomes Chiefs	82.9	710	116.1	19.1
3	Allen Bills	81.7	729	112.1	13.0
4	Tannehill Titans	78.3	594	68.2	22.1
5	Fitzpatrick Dolphins	76.9	324	41.6	5.6
6	Brees Saints	74.6	428	62.5	1.0
7	Jackson Ravens	73.7	585	50.9	30.8
8	Wilson Seahawks	73.5	716	88.6	9.1
9	Brady Buccaneers	72.5	681	90.4	-3.1
10	Mayfield Browns	72.2	597	76.9	3.4

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	A. Rodgers Packers	84.4	608	98.4	9.3
2	P. Mahomes Chiefs	82.9	710	116.1	19.1
3	J. Allen Bills	81.7	729	112.1	13.0
4	R. Tannehill Titans	78.3	594	68.2	22.1
5	R. Fitzpatrick Dolphins	76.9	324	41.6	5.6
6	D. Brees Saints	74.6	428	62.5	1.0
7	L. Jackson Ravens	73.7	585	50.9	30.8
8	R. Wilson Seahawks	73.5	716	88.6	9.1
9	T. Brady Buccaneers	72.5	681	90.4	-3.1
10	B. Mayfield Browns	72.2	597	76.9	3.4

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` integration

The 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` example

Here’s a quick example from kableExtra, which can be adapted to work in gt, mainly incorporating an inline boxplot into the table.

library(kableExtra)
library(gt)
library(tidyverse)

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.

spec_plot(mpg_list) %>% 
  pluck("4") %>% 
  str()

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!

spec_plot(mpg_list) %>% 
  map("svg_text") %>% 
  str()

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.

spec_plot(mpg_list) %>% 
  map("svg_text") %>% 
  map(gt::html) %>% 
  str()

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

Do it all in `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

Use a single source of data

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 × 5] (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 [134 × 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

Interactive `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

Forest

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)

Code to generate fake data

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

More custom HTML work

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.

Function to add tooltip to a table column label

library(htmltools) # Add tooltip to column labels with_tooltip <- function(value, tooltip) { tags$abbr(style = "text-decoration: underline; text-decoration-style: solid; cursor: question; color: blue", title = tooltip, value) }

Function that creates a star rating scale from 0-5

# 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() }

Create a “badge” style label with a specific color, and round edges.

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() }

Example of a inline bar chart made purely with 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 Key
MPG: Miles Per Gallon
Cyl: Cylinders
disp: Displacement
hp: Horsepower
rank_change: Rank Change
rating: Rating

Put it all together

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.

Data Prep

qbr_match <- qbr_weekly %>% filter(short_name %in% unique(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" = "team_name")) %>% select(short_name, team, head, qbr_weekly:run, wins, losses, pts_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 Seah… https… <dbl [7]> 81.9 8.10 328 7.43 1.17 2 P. Mahomes Chie… https… <dbl [8]> 76.9 18.5 347 7.22 1.29 3 A. Rodgers Pack… https… <dbl [7]> 76.7 29.5 285 6.3 0.586 4 D. Brees Sain… https… <dbl [7]> 75.8 11.6 280 6.31 0.171 5 J. Allen Bills https… <dbl [8]> 75.0 18.5 362 6.64 1.21 6 R. Tannehi… Tita… https… <dbl [7]> 74.1 18.1 284 5.81 1.13 7 D. Carr Raid… https… <dbl [7]> 71.8 18.0 284 5.69 0.357 8 K. Murray Card… https… <dbl [7]> 69.9 19.3 340 3.81 2.69 9 M. Ryan Falc… https… <dbl [8]> 69.6 27.4 370 5.54 0.662 10 T. Brady Bucc… https… <dbl [8]> 67.6 23.5 349 5.88 -0.262 # … with 13 more rows, and 2 more variables: pts_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: 32 x 4 short_name qbr rank_chg rank <chr> <dbl> <dbl> <dbl> 1 R. Wilson 81.9 0 1 2 P. Mahomes 76.9 5 2 3 A. Rodgers 76.7 1 3 4 D. Brees 75.8 1 4 5 J. Allen 75.0 -3 5 6 J. Herbert 74.1 3 6 7 R. Tannehill 74.1 -4 7 8 R. Fitzpatrick 72.6 0 8 9 D. Carr 71.8 -3 9 10 K. Murray 69.9 2 10 # … with 22 more rows

We can then combine the player name, team, and win-loss record into one set of “data” presented with some HTML formatting.

Code for Name/Team/Record Combo

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, pts_for) combo_df

# A tibble: 23 x 8 rank rank_chg head combo qbr qbr_weekly plays pts_for <int> <dbl> <chr> <lis> <dbl> <list> <dbl> <dbl> 1 1 0 https://a.espn… <htm… 81.9 <dbl [7]> 328 459 2 2 5 https://a.espn… <htm… 76.9 <dbl [8]> 347 473 3 3 1 https://a.espn… <htm… 76.7 <dbl [7]> 285 509 4 4 1 https://a.espn… <htm… 75.8 <dbl [7]> 280 482 5 5 -3 https://a.espn… <htm… 75.0 <dbl [8]> 362 501 6 6 -4 https://a.espn… <htm… 74.1 <dbl [7]> 284 491 7 7 -3 https://a.espn… <htm… 71.8 <dbl [7]> 284 434 8 8 2 https://a.espn… <htm… 69.9 <dbl [7]> 340 410 9 9 3 https://a.espn… <htm… 69.6 <dbl [8]> 370 396 10 10 6 https://a.espn… <htm… 67.6 <dbl [8]> 349 492 # … with 13 more rows

Table Code

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", pts_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(pts_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

Seahawks  12-4
81.9 328 459

2 5
P. Mahomes

Chiefs  14-2
76.9 347 473

3 1
A. Rodgers

Packers  13-3
76.7 285 509

4 1
D. Brees

Saints  12-4
75.8 280 482

5 -3
J. Allen

Bills  13-3
75.0 362 501

6 -4
R. Tannehill

Titans  11-5
74.1 284 491

7 -3
D. Carr

Raiders  8-8
71.8 284 434

8 2
K. Murray

Cardinals  8-8
69.9 340 410

9 3
M. Ryan

Falcons  4-12
69.6 370 396

10 6
T. Brady

Buccaneers  11-5
67.6 349 492

11 3
D. Watson

Texans  4-12
66.7 305 384

12 -3
M. Stafford

Rams  10-6
64.0 295 372

13 2
T. Bridgewater

Panthers  5-11
63.8 329 350

14 3
P. Rivers

Colts  11-5
63.2 256 451

15 -3
B. Mayfield

Browns  11-5
63.1 271 408

16 -9
L. Jackson

Ravens  11-5
62.7 282 468

17 -1
D. Jones

Giants  6-10
62.3 346 280

18 -8
J. Goff

Lions  5-11
61.5 328 377

19 -1
B. Roethlisberger

Steelers  12-4
58.9 283 416

20 1
J. Burrow

Bengals  4-11
55.7 426 311

21 2
K. Cousins

Vikings  7-9
52.9 232 430

22 -4
C. Wentz

Colts  11-5
52.3 407 451

23 -2
G. Minshew II

Jaguars  1-15
50.8 331 306

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!

Share:

	Inclisiran	Placebo

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

MPG	cyl	disp	hp	cylinder
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 Key MPG: Miles Per Gallon Cyl: Cylinders disp: Displacement hp: Horsepower rank_change: Rank Change rating: Rating

NFL QBR through Week 8
RK		QB		QBR	WEEKLY	PLAYS	PF
1			R. Wilson Seahawks 12-4	81.9		328	459
2	5		P. Mahomes Chiefs 14-2	76.9		347	473
3	1		A. Rodgers Packers 13-3	76.7		285	509
4	1		D. Brees Saints 12-4	75.8		280	482
5	-3		J. Allen Bills 13-3	75.0		362	501
6	-4		R. Tannehill Titans 11-5	74.1		284	491
7	-3		D. Carr Raiders 8-8	71.8		284	434
8	2		K. Murray Cardinals 8-8	69.9		340	410
9	3		M. Ryan Falcons 4-12	69.6		370	396
10	6		T. Brady Buccaneers 11-5	67.6		349	492
11	3		D. Watson Texans 4-12	66.7		305	384
12	-3		M. Stafford Rams 10-6	64.0		295	372
13	2		T. Bridgewater Panthers 5-11	63.8		329	350
14	3		P. Rivers Colts 11-5	63.2		256	451
15	-3		B. Mayfield Browns 11-5	63.1		271	408
16	-9		L. Jackson Ravens 11-5	62.7		282	468
17	-1		D. Jones Giants 6-10	62.3		346	280
18	-8		J. Goff Lions 5-11	61.5		328	377
19	-1		B. Roethlisberger Steelers 12-4	58.9		283	416
20	1		J. Burrow Bengals 4-11	55.7		426	311
21	2		K. Cousins Vikings 7-9	52.9		232	430
22	-4		C. Wentz Colts 11-5	52.3		407	451
23	-2		G. Minshew II Jaguars 1-15	50.8		331	306
Data: ESPN

Embedding custom HTML in gt tables

gt loves HTML

More HTML!

kableExtra integration

kableExtra example

gt + kableExtra

Do it all in gt

Use a single source of data

Interactive sparklines

Forest

More custom HTML work

Table Key

Put it all together

NFL QBR through Week 8

Citation