Embedding custom HTML in gt tables

data visualization tables gt tidyverse

HTML is basically a superpower.

Thomas Mock https://twitter.com/thomas_mock
10-31-2020

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.

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}%\"> &nbsp; </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}&nbsp;&nbsp;{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!



Citation

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