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	GB	87.1	320	50.2	4.9
2	Mahomes	KC	85.2	398	63.7	10.5
3	Wilson	SEA	81.5	377	44.1	9.0
4	Fitzpatrick	MIA	80.6	242	27.6	6.2
5	Allen	BUF	80.5	416	53.5	9.6
6	Brees	NO	79.2	280	39.8	1.2
7	Tannehill	TEN	77.3	309	36.3	8.2
8	Carr	LV	76.9	284	34.4	2.4
9	Prescott	DAL	76.2	263	27.0	4.9
10	Ryan	ATL	75.3	370	36.7	5.3

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 GB	87.1	320	50.2	4.9
2	Mahomes KC	85.2	398	63.7	10.5
3	Wilson SEA	81.5	377	44.1	9.0
4	Fitzpatrick MIA	80.6	242	27.6	6.2
5	Allen BUF	80.5	416	53.5	9.6
6	Brees NO	79.2	280	39.8	1.2
7	Tannehill TEN	77.3	309	36.3	8.2
8	Carr LV	76.9	284	34.4	2.4
9	Prescott DAL	76.2	263	27.0	4.9
10	Ryan ATL	75.3	370	36.7	5.3

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 GB	87.1	320	50.2	4.9
2	Mahomes KC	85.2	398	63.7	10.5
3	Wilson SEA	81.5	377	44.1	9.0
4	Fitzpatrick MIA	80.6	242	27.6	6.2
5	Allen BUF	80.5	416	53.5	9.6
6	Brees NO	79.2	280	39.8	1.2
7	Tannehill TEN	77.3	309	36.3	8.2
8	Carr LV	76.9	284	34.4	2.4
9	Prescott DAL	76.2	263	27.0	4.9
10	Ryan ATL	75.3	370	36.7	5.3

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 GB	87.1	320	50.2	4.9
2	Mahomes KC	85.2	398	63.7	10.5
3	Wilson SEA	81.5	377	44.1	9.0
4	Fitzpatrick MIA	80.6	242	27.6	6.2
5	Allen BUF	80.5	416	53.5	9.6
6	Brees NO	79.2	280	39.8	1.2
7	Tannehill TEN	77.3	309	36.3	8.2
8	Carr LV	76.9	284	34.4	2.4
9	Prescott DAL	76.2	263	27.0	4.9
10	Ryan ATL	75.3	370	36.7	5.3

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 GB	87.1	320	50.2	4.9
2	P. Mahomes KC	85.2	398	63.7	10.5
3	R. Wilson SEA	81.5	377	44.1	9.0
4	R. Fitzpatrick MIA	80.6	242	27.6	6.2
5	J. Allen BUF	80.5	416	53.5	9.6
6	D. Brees NO	79.2	280	39.8	1.2
7	R. Tannehill TEN	77.3	309	36.3	8.2
8	D. Carr LV	76.9	284	34.4	2.4
9	D. Prescott DAL	76.2	263	27.0	4.9
10	M. Ryan ATL	75.3	370	36.7	5.3

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 × 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

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% 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.

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, 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

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", 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!

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

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