Client-side interactivity - do more with Crosstalk

Update on reactable

Greg Lin, the author of reactable recently added support for crosstalk to the package! This is great, because it allows you to do many things:

• Add client-side interactivity
  • eg Shiny-lite without a server!
    
• Combine interactivity between multiple HTML Widgets
  • Have a interactive plot interact with an interactive table
    
• Pass client-side interactions back to a Shiny runtime

We’ll continue on our example use-cases of interactive tables w/ reactable, but now add in a bit of crosstalk to show how this can be useful.

My previous posts on:
- reactable - How to guide for interactive tables
- gt - How to guide for static tables

1st Round WRs

Like most examples, we’ll need additional data for this example. ESPN was kind enough to give us a hot-take to start off with:

Source: https://twitter.com/SportsCenter/status/1255168243863609344

Pretty striking huh? Of these tops QBs, Rodgers has almost no 1st round receivers on his team (or TE/RB). But what about the rest of the story? WHO does he throw TDs to?

Let’s take a look at the data, courtesy of pro-football-reference.com. The following 3 data sources got me these results (and the raw RDS file output can be found here & here).

• PFR Draft Query
  • This allows you to specify positions, years, etc
    
• PFR Pass TD table
  • This is ALL the top players and the number of TDs they’s thrown, with sub-links to each of the QB’s homepage, which has an additional list of WHO caught each of these passes
    
• PFR Draft by Year
  • This is the draft results by year, I joined this against the passing list for each of these QBs to align draft data.

Note that I did a rough join by name, I’m not THAT concerned with confirming the data, but I did a spot check down to receivers with 10 or more TDs

Prep the data

Let’s read in our data - however note that this is long-format, so it’s not ideal for our summary table. We’ll tidyr::pivot_wider() in the next step and use some new dplyr features!

However we can see that we have:
- a passer
- a draft round variable (round)
- total touchdowns thrown (n)
- total touchdowns thrown (total)
- the ratio of touchdowns thrown per round relative to the total touchdowns normalized to each passer (ratio).

library(htmltools)
library(tidyverse)

── Attaching packages ─────────────────────────────────────── tidyverse 1.3.1 ──

✔ ggplot2 3.3.5     ✔ purrr   0.3.4
✔ tibble  3.1.6     ✔ dplyr   1.0.8
✔ tidyr   1.2.0     ✔ stringr 1.4.0
✔ readr   2.1.2     ✔ forcats 0.5.1

── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
✖ dplyr::filter() masks stats::filter()
✖ dplyr::lag()    masks stats::lag()

library(reactable)

# read in our summary data
summary_qbs <- readr::read_rds("summary_qbs.rds")

glimpse(summary_qbs)

Rows: 96
Columns: 5
$ passer <chr> "Aaron Rodgers", "Aaron Rodgers", "Aaron Rodgers", "Aaron Rodge…
$ rnd    <fct> Rnd 1, Rnd 2, Rnd 3, Rnd 4, Rnd 5, Rnd 6, Rnd 7, Undrafted, Rnd…
$ n      <int> 1, 191, 82, 5, 23, 6, 24, 32, 69, 31, 101, 35, 17, 77, 3, 32, 6…
$ total  <int> 364, 364, 364, 364, 364, 364, 364, 364, 365, 365, 365, 365, 365…
$ ratio  <dbl> 0.002747253, 0.524725275, 0.225274725, 0.013736264, 0.063186813…

We’ll use tidyr::unnest_wider() to widen this data where each passer/QB get their own row and the round of their receivers get their own column. This is ready to go into it’s own table!

# make the data wider
wide_qbs <- summary_qbs %>% 
  # drop total TDs
  select(passer, rnd, ratio) %>% 
  # round the ratio (we don't need 8 digits of accuracy)
  mutate(ratio = round(ratio, digits = 3)) %>% 
  # Move rnd and ratio to wide-form data
  pivot_wider(
    names_from = rnd, 
    values_from = ratio
    ) %>% 
  group_by(passer) %>% 
  mutate(
    # Createa a top 3 rounds var
    `Rnds 1-3` = `Rnd 1`+ `Rnd 2` + `Rnd 3`, 
    # this is a dplyr 1.0 feature
    # place the new column before Undrafted - new to dplyr 1.0
    .before = Undrafted) %>% 
  ungroup() # always ungroup!

wide_qbs %>% 
  glimpse()

Rows: 12
Columns: 10
$ passer     <chr> "Aaron Rodgers", "Ben Roethlisberger", "Carson Palmer", "Dr…
$ `Rnd 1`    <dbl> 0.003, 0.189, 0.196, 0.190, 0.358, 0.514, 0.406, 0.547, 0.1…
$ `Rnd 2`    <dbl> 0.525, 0.085, 0.227, 0.112, 0.212, 0.000, 0.196, 0.030, 0.1…
$ `Rnd 3`    <dbl> 0.225, 0.277, 0.221, 0.152, 0.098, 0.168, 0.100, 0.076, 0.0…
$ `Rnd 4`    <dbl> 0.014, 0.096, 0.012, 0.042, 0.040, 0.112, 0.025, 0.132, 0.1…
$ `Rnd 5`    <dbl> 0.063, 0.047, 0.081, 0.029, 0.064, 0.022, 0.085, 0.020, 0.0…
$ `Rnd 6`    <dbl> 0.016, 0.211, 0.025, 0.004, 0.042, 0.012, 0.075, 0.043, 0.0…
$ `Rnd 7`    <dbl> 0.066, 0.008, 0.146, 0.141, 0.019, 0.028, 0.000, 0.004, 0.0…
$ `Rnds 1-3` <dbl> 0.753, 0.551, 0.644, 0.454, 0.668, 0.682, 0.702, 0.653, 0.3…
$ Undrafted  <dbl> 0.088, 0.088, 0.090, 0.331, 0.167, 0.143, 0.114, 0.148, 0.4…

Create a color palette

We’ll create a color palette function using viridis.

# create a color function
vir_scale_col <- function(x) rgb(colorRamp(c(viridis::viridis_pal(begin = 0.5, end = 1)(10) %>% rev()))(x), maxColorValue = 255)

# min val of ratio
qb_min <- summary_qbs %>% 
  summarize(min = min(ratio)) %>% 
  pull(min)

# max value of ratio
qb_max <- summary_qbs %>% 
  filter(rnd %in% c("Rnd 1", "Rnd 2", "Rnd 3")) %>% 
  group_by(passer) %>% 
  summarize(sum = sum(ratio)) %>% 
  summarize(max = max(sum) + 0.01) %>% 
  pull(max)

# show the range from min to max
seq(from = qb_min, to = qb_max, length.out = 9) %>% 
  vir_scale_col() %>% scales::show_col()

Create the table

Now we can create the table - here is the basic table that gets us most of the way!

I’ve added comments to the code so you can see what the arguments do.

table_out <- wide_qbs %>% 
  reactable(
    pagination = FALSE, # all one page
    searchable = TRUE,  # add a search bar
    striped = TRUE,  # add stripes
    highlight = TRUE, # highlight on hover
    compact = TRUE, # compact the table
    fullWidth = FALSE, # don't fill the page
    defaultSortOrder = "desc", # default to descending order sort
    defaultSorted = c("Rnd 1"), # default to sorting by Rnd 1 val
    # apply our color function across numeric values
    defaultColDef = colDef(
      style = function(value) {
        if (!is.numeric(value)) return()
        normalized <- value/0.756
        color <- vir_scale_col(normalized)
        list(background = color, fontWeight = "bold")
      },
      # convert to percent for numeric
      format = colFormat(percent = TRUE, digits = 1),
      # default to 80px wide
      minWidth = 80
    )
    )

table_out

We’ll add in a few fonts (locally this time, instead of from Google), add some additional styling, and then I’m happy with this as an output table. Feel free to compare to what round of receivers QBs are throwing to, and you have filtering via the search bar.

While Aaron Rodgers hasn’t thrown hardly any passes to 1st Rounders - he actually leads this group in passes thrown to 1st, 2nd and 3rd rounders! The story can change a bit based on how you choose the data/cutoff. However, there’s a bit more to this story that is missing from the below table.

table_out <- wide_qbs %>%
  reactable(
    pagination = FALSE, # all one page
    searchable = TRUE, # add a search bar
    striped = TRUE, # add stripes
    highlight = TRUE, # highlight on hover
    compact = TRUE, # compact the table
    fullWidth = FALSE, # don't fill the page
    defaultSortOrder = "desc", # default to descending order sort
    defaultSorted = c("Rnd 1"), # default to sorting by Rnd 1 val
    # apply our color function across numeric values
    defaultColDef = colDef(
      style = function(value) {
        if (!is.numeric(value)) return()
        normalized <- value / 0.756
        color <- vir_scale_col(normalized)
        list(background = color, fontWeight = "bold")
      },
      # convert to percent for numeric
      format = colFormat(percent = TRUE, digits = 1),
      # default to 80px wide
      minWidth = 80
    ),
    ### Additions made below ###
    ############################

    # change specific columns from default
    columns = list(
      passer = colDef(
        name = "QB", # change display name
        minWidth = 150, # widen the column
        # highlight Aaron Rodgers
        style = function(value) {
          weight_name <- if (value == "Aaron Rodgers") {
            800
          } else if (value != "Aaron Rodgers") {
            500
          }
          list(fontWeight = weight_name, fontFamily = "Lato")
        }
      ),
      Undrafted = colDef(
        name = "UDFA"
      )
    ),
    theme = reactableTheme(
      # set a default theme for font across table
      style = list(fontFamily = "Fira Mono")
    )
  )

# Note I'm using htmltools to build up these div containers
# for better web display as I'm using RMarkdown to build up a webpage.
div(
  h2("Percent of Touchdowns thrown to players by draft round"),
  h3("Normalized to each passer's total passing touchdowns"),
  table_out,
  "Table: @thomas_mock | Data: pro-football-reference.com"
)

Percent of Touchdowns thrown to players by draft round

Normalized to each passer's total passing touchdowns

Table: @thomas_mock | Data: pro-football-reference.com

This table shows us a lot - Rodgers actually has thrown the most passes to 2nd Round receivers of any of these QBs, and the most passes to 1st, 2nd or 3rd Round receivers, along with the fewest passes to undrafted receivers! Not quite, the same storyline. An additional consideration - where in the overall draft were the players catching passes taken?

Spoiler - most of Rodger’s receivers were actually top 4-5 WRs in their respective draft classes.

Let’s talk about crosstalk

For a bit of a deeper dive, we can go up one level and rather than focusing on just the QBs, we can look at the QBs and stats on who has caught their passes. We’ll also use crosstalk to provide some rich interactive filtering purely on the client side, this means all done in browser as opposed to needing a Shiny runtime/server backend.

Our first step is to load the crosstalk library and define our SharedData - this is how crosstalk knows how to relate the interaction together - the data is added to a new object that is shared across various resources. For simple examples, once this is defined you can just use the newly defined wr_data just as you would normal dataframes.

Let’s try it out!

library(crosstalk)

joined_tds <- read_rds("joined_tds.rds") %>% 
  # drop some QBs to keep it at 8 for example purposes
  filter(!passer %in% c("Matthew Stafford", "Carson Palmer", "Eli Manning", 
                        "Matt Ryan"))

wr_data <- SharedData$new(joined_tds)

For this first table, we’ll just stay simple, with the major addition being that we’re adding a longer description to the pos_rank column which is a tricky definition. You can now hover over the column label to get a tooltip. I’ve also done something relatively easy to do, but that adds some complexity. I’ve grouped each QB so that their WRs display as sub-tables within the parent row. You can “open” the quarterback rows by clicking on the arrow next to their name.

The other reactable portion I’ve done is providing specific summary statistics at the level of the QB group. We accomplish this with groupBy inside reactable, and you then define what type of aggregation you want inside the colDef. I have unique teams for team, count of total receivers for receiver, sum of total TDs for TDs caught, unique position draft rank for position draft, and frequency for draft round. Note that you can still interact with this table normally, and that we haven’t used any special crosstalk features yet. Also: side note - I’ve replaced undrafted players with a pos_rank of 44. This is the max of pos_rank for drafted players + 1. Deal with it! (#sorry).

I’m much more interested in spending more time on how-to-guides than adding in 150 undrafted free agent ranks. 🤷

h3("Touchdown recipients grouped by quarterback")

Touchdown recipients grouped by quarterback

# Create a better tooltip for the specific column of interest
with_tooltip <- function(value, tooltip) {
  span(
    style = "text-decoration: underline;",
    title = tooltip, value
  )
}


wr_table <- reactable(wr_data,
  pagination = FALSE,
  compact = TRUE,
  # Group by for the aggregation
  groupBy = "passer",
  columns = list(
    passer = colDef(
      name = "QB",
      minWidth = 120, align = "left",
      style = list(fontFamily = "Lato")
    ),
    tm = colDef(
      name = "Team",
      align = "center",
      # add unique teams
      aggregate = "unique",
      style = list(fontFamily = "Lato")
    ),
    scorer_receiver = colDef(
      name = "Receiver",
      align = "left",
      # add count of total receivers
      aggregate = "count",
      style = list(fontFamily = "Lato")
    ),
    n = colDef(
      name = "TDs Caught",
      align = "right",
      # add sum of total TDs
      aggregate = "sum"
    ),
    rnd = colDef(
      name = "Draft Round",
      align = "left",
      # add freq by draft round
      # sorted by total tds
      aggregate = "frequency"
    ),
    pos_rank = colDef(
      # here's the full tooltip
      header = with_tooltip("Position Draft", "Within their position and draft year, what number they were drafted"),
      align = "right",
      # add unique draft round 
      # sorted by total tds
      aggregate = "unique"
    )
  ),
    theme = reactableTheme(
      # set a default theme for font across table
      style = list(fontFamily = "Fira Mono")
    )
  )


wr_table

crosstalk add ons

So that table is interactive, but it’s all sorting. What about all the special crosstalk features?

We can align some filters and the table together with bootstrap columns (similar to setting up shiny structure). These come along with loading crosstalk. Note that this is because I’m working in a traditional RMarkdown to build this distill website, and if I were using something like flexdashboard, it has alternate and more robust methods of aligning various plots, tables, control boxes, etc.

Also! Note that because I’m using the shared data across multiple areas, if I filter at any stage it will effect ALL the shared data tables. So if you play with the example below, make sure to reset all the settings before continuing on.

# bootstrap columns
h3("Interactive QB Table with Filtering")

Interactive QB Table with Filtering

bscols(
  # bootstrap is built off a 12 wide grid system,
  # so we have 1/6 and 5/6 width below
  widths = c(2, 10),
  list(
    # Create shiny-esque filters
    # Note that we are defining:
    # a name for the filter
    # a display name for the filter
    # a shared data object
    # and a column of interest (w/ a ~)
    filter_checkbox("type", "Round", wr_data, ~rnd),
    filter_slider("tds", "Total TDs", wr_data, ~n, width = "100%"),
    filter_slider("pos_rank", "Pos Rank", wr_data, ~pos_rank, width = "100%"),
    filter_select("qb", "Quarterback", wr_data, ~passer)
  ),
  # add our table next to the filters
  wr_table
)

Round

Rnd 1

Rnd 2

Rnd 3

Rnd 4

Rnd 5

Rnd 6

Rnd 7

UDFA

Total TDs

Pos Rank

Quarterback

That’s it! No setting up shiny, no server, you get all this filtering for free! Now there’s still a spectrum where shiny adds a LOT of value - namely, I want to do more custom work and need to execute additional R code!

Additional crosstalk features

Now while the table-level filtering is nice, you can also communicate between various crosstalk enabled widgets, including plotly graphs, reactable, DT, and leaflet.

This is a rather minimal example as far as plotly, but you can see some of the interaction across the 3 levels (filters, plotly, reactable). The main additions I have for plotly are adding specific hover text.

As a fun exploration - try filtering Pos Rank to 1-5 - Rodgers has 7 receivers in this category.

library(plotly)

Attaching package: 'plotly'

The following object is masked from 'package:ggplot2':

    last_plot

The following object is masked from 'package:stats':

    filter

The following object is masked from 'package:graphics':

    layout

# add a div so that the various components get bound together
div(
  h3("Compare and filter WR touchdowns by QB, Round, or Draft Position"),
  h4("Filter by: round drafted, total TDs, positional rank drafted, or QB"),
  # use bootstrap columns for the crosstalk stuff
  bscols(
  # bootstrap is built off a 12 wide grid system,
  # so we have 1/6 and 5/6 width below
  widths = c(2, 10),
  list(
    # Create shiny-esque filters
    filter_checkbox("type", "Round", wr_data, ~rnd),
    filter_slider("tds", "Total TDs", wr_data, ~n, width = "100%"),
    filter_slider("pos_rank", "Pos Rank", wr_data, ~pos_rank, width = "100%"),
    filter_select("qb", "Quarterback", wr_data, ~passer)
  ),
  # add our table next to the filters
  plot_ly(wr_data, y = ~passer, x = ~n, 
          color = ~passer, text = ~scorer_receiver) %>% 
  add_bars(width = 1,
           # Add specific text to hover
           hovertemplate = "%{text}<br>%{x} TDs") %>% 
    # reverse the Y axis
    layout(yaxis = list(autorange = "reversed"))
),
wr_table,
"Graphic: @thomas_mock | Data: Pro-football-reference.com"
)

Compare and filter WR touchdowns by QB, Round, or Draft Position

Filter by: round drafted, total TDs, positional rank drafted, or QB

Round

Rnd 1

Rnd 2

Rnd 3

Rnd 4

Rnd 5

Rnd 6

Rnd 7

UDFA

Total TDs

Pos Rank

Quarterback

Graphic: @thomas_mock | Data: Pro-football-reference.com

So overall - we’re able to do some exploration of the data at specific filters very easily and without having to setup or do a lot of extra work.

Followup

This can be further extended to shiny - where some of the interaction can happen at the level of the client (ie JavaScript) and other portions can be pushed down to R (shiny) or even a database backend (ie SQL).

Hopefully this gives you an additional picture as to WHY interactive tables and/or client-side interactivity can help expand your ability to share details in R.

That’s out of scope for today, but reading material at:
- Free plotly R book
- crosstalk + Shiny website

Expand for Session Info

─ Session info ───────────────────────────────────────────────────────────────
 setting  value
 version  R version 4.2.0 (2022-04-22)
 os       macOS Monterey 12.2.1
 system   aarch64, darwin20
 ui       X11
 language (EN)
 collate  en_US.UTF-8
 ctype    en_US.UTF-8
 tz       America/Chicago
 date     2022-04-28
 pandoc   2.18 @ /Applications/RStudio.app/Contents/MacOS/quarto/bin/tools/ (via rmarkdown)
 quarto   0.9.294 @ /usr/local/bin/quarto

─ Packages ───────────────────────────────────────────────────────────────────
 package     * version date (UTC) lib source
 crosstalk   * 1.2.0   2021-11-04 [1] CRAN (R 4.2.0)
 dplyr       * 1.0.8   2022-02-08 [1] CRAN (R 4.2.0)
 forcats     * 0.5.1   2021-01-27 [1] CRAN (R 4.2.0)
 ggplot2     * 3.3.5   2021-06-25 [1] CRAN (R 4.2.0)
 htmltools   * 0.5.2   2021-08-25 [1] CRAN (R 4.2.0)
 plotly      * 4.10.0  2021-10-09 [1] CRAN (R 4.2.0)
 purrr       * 0.3.4   2020-04-17 [1] CRAN (R 4.2.0)
 reactable   * 0.2.3   2020-10-04 [1] CRAN (R 4.2.0)
 readr       * 2.1.2   2022-01-30 [1] CRAN (R 4.2.0)
 sessioninfo * 1.2.2   2021-12-06 [1] CRAN (R 4.2.0)
 stringr     * 1.4.0   2019-02-10 [1] CRAN (R 4.2.0)
 tibble      * 3.1.6   2021-11-07 [1] CRAN (R 4.2.0)
 tidyr       * 1.2.0   2022-02-01 [1] CRAN (R 4.2.0)
 tidyverse   * 1.3.1   2021-04-15 [1] CRAN (R 4.2.0)

 [1] /Library/Frameworks/R.framework/Versions/4.2-arm64/Resources/library

──────────────────────────────────────────────────────────────────────────────