Last active
September 14, 2022 23:20
-
-
Save jthomasmock/27f83bba683ae4be7293ddf0ade59c80 to your computer and use it in GitHub Desktop.
Quick table for QBR
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| library(tidyverse) | |
| library(glue) | |
| library(gt) | |
| library(kableExtra) | |
| library(espnscrapeR) | |
| # 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:7) %>% | |
| pmap_dfr(.f = get_nfl_qbr) | |
| # create "plots" via kableExtra to embed in gt | |
| qbr_match <- qbr_weekly %>% | |
| filter(short_name %in% nfl_qbr$short_name) %>% | |
| group_by(short_name) %>% | |
| summarise(qbr_weekly = list(qbr_total), .groups = "drop") %>% | |
| mutate( | |
| qbr_weekly = kableExtra::spec_plot(qbr_weekly, xlim = c(0, 100), polymin = 0, height = 80), | |
| qbr_weekly = map(qbr_weekly, "svg_text"), | |
| qbr_weekly = map(qbr_weekly, ~gt::html(as.character(.x))) | |
| ) | |
| # clean up the data a bit and combine | |
| tab_df <- nfl_qbr %>% | |
| select(abb_name = team, contains("name"), qbr = qbr_total, epa = total_epa, qb_plays, pass, run, headshot_href) %>% | |
| left_join(nfl_standings) %>% | |
| select(short_name, abb_name, head = headshot_href, qbr, qb_plays, wins, losses, points_for) %>% | |
| mutate(wl = glue("{wins}-{losses}")) %>% | |
| left_join(qbr_match, by = "short_name") %>% | |
| select(-wins, -losses) | |
| # Write a function to "stack" the QB name + team and record | |
| upper_first <- function(x){ | |
| # get first word and capitalize | |
| word1 <- word(x, 1, 2) %>% | |
| str_to_upper() | |
| # get last two words | |
| word2 <- word(x, -2, -1) | |
| # I'm basically writing the HTML by hand here | |
| glue("<span style ='font-weight:bold;font-size:12px;'>{word1}</span><br> | |
| <span style = 'font-size:10px;color:darkgrey;'>{word2}</span>") | |
| } | |
| # theme to apply for the table | |
| gt_theme_538 <- function(data,...) { | |
| data %>% | |
| opt_all_caps() %>% | |
| opt_table_font( | |
| font = list( | |
| google_font("Chivo"), | |
| default_fonts() | |
| ) | |
| ) %>% | |
| tab_style( | |
| style = cell_borders( | |
| sides = "bottom", color = "transparent", weight = px(2) | |
| ), | |
| locations = cells_body( | |
| columns = TRUE, | |
| # This is a relatively sneaky way of changing the bottom border | |
| # Regardless of data size | |
| rows = nrow(data$`_data`) | |
| ) | |
| ) %>% | |
| tab_options( | |
| column_labels.background.color = "white", | |
| table.border.top.width = px(3), | |
| table.border.top.color = "transparent", | |
| table.border.bottom.color = "transparent", | |
| table.border.bottom.width = px(3), | |
| column_labels.border.top.width = px(3), | |
| column_labels.border.top.color = "transparent", | |
| column_labels.border.bottom.width = px(3), | |
| column_labels.border.bottom.color = "black", | |
| data_row.padding = px(1), | |
| source_notes.font.size = 12, | |
| table.font.size = 16, | |
| heading.align = "left", | |
| ... | |
| ) | |
| } | |
| # output the table! | |
| tab_df %>% | |
| slice(1:16) %>% | |
| gt() %>% | |
| text_transform( | |
| location = cells_body(vars(head)), | |
| fn = function(x){ | |
| web_image(x) | |
| } | |
| ) %>% | |
| cols_merge(columns = vars(short_name, abb_name, wl)) %>% | |
| text_transform( | |
| locations = cells_body(vars(short_name)), | |
| fn = function(x){ | |
| combo = map_chr(x, upper_first) | |
| combo = map(combo, gt::html) | |
| combo | |
| } | |
| ) %>% | |
| cols_label( | |
| short_name = "Quarterback", | |
| head = "", | |
| qbr = "QBR", | |
| qb_plays = "Plays", | |
| points_for = gt::html("Team<br>Pts"), | |
| qbr_weekly = "QBR Weekly" | |
| ) %>% | |
| gt_theme_538() %>% | |
| tab_source_note( | |
| source_note = md("**Data**: ESPN<br>**Table**: @thomas_mock") | |
| ) %>% | |
| tab_header( | |
| title = md("**NFL QBR through week 7**"), | |
| subtitle = "Limited to top 16 players" | |
| ) |
Author
jthomasmock
commented
Oct 29, 2020
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment