NBA Advanced Metrics

Box Plus/Minus Tables

print_glyphs <- unescape_html(str_c(glyphs, sep = ",", collapse = ", "))

Because I super love playing with Rich Iannone’s {gt}:

adv_player_stats %>%
  select(namePlayer, idPosition, ratioBPM, ratioOBPM, ratioDBPM, bref_url, urlPlayerHeadshot) %>%
  arrange(desc(ratioBPM)) %>%
  top_n(n = 10, wt = ratioBPM) %>%
  gt::gt(rowname_col = "namePlayer") %>%
  tab_header(
    title = md("**Top 10 Box Plus/Minus**")
  ) %>%
  cols_label(
    idPosition = md("**Position**"),
    ratioBPM = md("**BPM**"),
    ratioOBPM = md("**OBPM**"),
    ratioDBPM = md("**DBPM**"),
    bref_url = md("**Link**"),
    urlPlayerHeadshot = md("")
  ) %>%
  text_transform(
    locations = cells_data(vars(bref_url)),
    fn = function(x) {
      sprintf("<a href=%s>profile</a>", x)
    }
  ) %>%
    text_transform(
    locations = cells_data(vars(urlPlayerHeadshot)),
    fn = function(x) {
      web_image(url = x) 
    }
  ) %>%
  tab_source_note(
    md("source: [basketball-reference.com](https://www.basketball-reference.com) via [nbastatR](http://asbcllc.com/nbastatR/index.html)")
  ) %>%
  tab_footnote(
    footnote = ("Players with 500+ minutes."),
    locations = cells_title("title")
    ) %>%
  tab_footnote(
    footnote = ("Box Plus/Minus: a box score estimate of the points per 100 possessions that a player contributed above a league-average player, translated to an average team."),
    locations = cells_column_labels(
      columns = vars(ratioBPM)
    )
  ) %>%
  tab_footnote(
    footnote = ("Offensive Box Plus/Minus."),
    locations = cells_column_labels(
      columns = vars(ratioOBPM)
    )
  ) %>%
  tab_footnote(
    footnote = ("Defensive Box Plus/Minus."),
    locations = cells_column_labels(
      columns = vars(ratioDBPM)
    )
  ) %>%
  tab_options(footnote.glyph = c(print_glyphs),
              table.width = px(640))

Top 10 Box Plus/Minus*
	Position	BPM †	OBPM ‡	DBPM §	Link
James Harden	PG	11.7	10.6	1.1	profile
Giannis Antetokounmpo	PF	10.8	5.7	5.1	profile
Nikola Jokic	C	9.6	5.8	3.8	profile
Anthony Davis	C	8.5	4.7	3.9	profile
LeBron James	SF	8.1	6.2	1.9	profile
Rudy Gobert	C	7.1	2.0	5.1	profile
Karl-Anthony Towns	C	6.8	4.8	1.9	profile
Kyrie Irving	PG	6.4	6.0	0.3	profile
Nikola Vucevic	C	6.4	3.0	3.4	profile
Russell Westbrook	PG	6.4	2.5	3.8	profile
source: basketball-reference.com via nbastatR
* Players with 500+ minutes. † Box Plus/Minus: a box score estimate of the points per 100 possessions that a player contributed above a league-average player, translated to an average team. ‡ Offensive Box Plus/Minus. § Defensive Box Plus/Minus.

adv_player_stats %>%
  select(urlPlayerHeadshot, namePlayer, idPosition, ratioBPM, ratioOBPM, ratioDBPM) %>%
  arrange(desc(ratioOBPM)) %>%
  top_n(n = 10, wt = ratioOBPM) %>%
  gt::gt() %>%
  tab_header(
    title = md("**Top 10 Offensive Box Plus/Minus**")
  ) %>%
  cols_label(
    namePlayer = md("**Player**"),
    urlPlayerHeadshot = md(""),
    idPosition = md("**Position**"),
    ratioBPM = md("**BPM**"),
    ratioOBPM = md("**OBPM**"),
    ratioDBPM = md("**DBPM**")
  ) %>%
    text_transform(
    locations = cells_data(vars(urlPlayerHeadshot)),
    fn = function(x) {
      web_image(url = x) 
    }
  ) %>%
  tab_source_note(
    md("source: [basketball-reference.com](https://www.basketball-reference.com) via [nbastatR](http://asbcllc.com/nbastatR/index.html)")
  ) %>%
  tab_footnote(
    footnote = ("Players with 500+ minutes."),
    locations = cells_title("title")
  ) %>%
  tab_footnote(
    footnote = ("Box Plus/Minus; a box score estimate of the points per 100 possessions that a player contributed above a league-average player, translated to an average team."),
    locations = cells_column_labels(
      columns = vars(ratioBPM)
    )
  ) %>%
  tab_footnote(
    footnote = ("Offensive Box Plus/Minus."),
    locations = cells_column_labels(
      columns = vars(ratioOBPM)
    )
  ) %>%
  tab_footnote(
    footnote = ("Defensive Box Plus/Minus."),
    locations = cells_column_labels(
      columns = vars(ratioDBPM)
    )
  ) %>%
  tab_options(footnote.glyph = c(print_glyphs),
              table.width = px(640))

Top 10 Offensive Box Plus/Minus*
	Player	Position	BPM †	OBPM ‡	DBPM §
	James Harden	PG	11.7	10.6	1.1
	Stephen Curry	PG	6.3	7.7	-1.4
	Damian Lillard	PG	5.6	6.6	-1.0
	LeBron James	SF	8.1	6.2	1.9
	Kyrie Irving	PG	6.4	6.0	0.3
	Nikola Jokic	C	9.6	5.8	3.8
	Giannis Antetokounmpo	PF	10.8	5.7	5.1
	Kemba Walker	PG	3.3	4.9	-1.6
	Karl-Anthony Towns	C	6.8	4.8	1.9
	Mike Conley	PG	3.4	4.8	-1.3
	Paul George	SF	5.4	4.8	0.7
source: basketball-reference.com via nbastatR
* Players with 500+ minutes. † Box Plus/Minus; a box score estimate of the points per 100 possessions that a player contributed above a league-average player, translated to an average team. ‡ Offensive Box Plus/Minus. § Defensive Box Plus/Minus.

adv_player_stats %>%
  select(urlPlayerHeadshot, namePlayer, idPosition, ratioBPM, ratioOBPM, ratioDBPM) %>%
  arrange(desc(ratioDBPM)) %>%
  top_n(n = 10, wt = ratioDBPM) %>%
  gt::gt() %>%
  tab_header(
    title = md("**Top 10 Defensive Box Plus/Minus**")
  ) %>%
  cols_label(
    namePlayer = md("**Player**"),
    urlPlayerHeadshot = md(""),
    idPosition = md("**Position**"),
    ratioBPM = md("**BPM**"),
    ratioOBPM = md("**OBPM**"),
    ratioDBPM = md("**DBPM**")
  ) %>%
    text_transform(
    locations = cells_data(vars(urlPlayerHeadshot)),
    fn = function(x) {
      web_image(url = x) 
    }
  ) %>%
  tab_source_note(
    md("source: [basketball-reference.com](https://www.basketball-reference.com) via [nbastatR](http://asbcllc.com/nbastatR/index.html)")
  ) %>%
  tab_footnote(
    footnote = ("Players with 500+ minutes."),
    locations = cells_title("title")
  ) %>%
  tab_footnote(
    footnote = ("Box Plus/Minus; a box score estimate of the points per 100 possessions that a player contributed above a league-average player, translated to an average team."),
    locations = cells_column_labels(
      columns = vars(ratioBPM)
    )
  ) %>%
  tab_footnote(
    footnote = ("Offensive Box Plus/Minus."),
    locations = cells_column_labels(
      columns = vars(ratioOBPM)
    )
  ) %>%
  tab_footnote(
    footnote = ("Defensive Box Plus/Minus."),
    locations = cells_column_labels(
      columns = vars(ratioDBPM)
    )
  ) %>%
  tab_options(footnote.glyph = c(print_glyphs),
              table.width = px(640))

Top 10 Defensive Box Plus/Minus*
	Player	Position	BPM †	OBPM ‡	DBPM §
	Nerlens Noel	C	3.8	-1.6	5.4
	Mitchell Robinson	C	5.9	0.6	5.3
	Giannis Antetokounmpo	PF	10.8	5.7	5.1
	Rudy Gobert	C	7.1	2.0	5.1
	Myles Turner	C	3.3	-1.4	4.7
	Anthony Davis	C	8.5	4.7	3.9
	Mason Plumlee	C	3.8	-0.1	3.9
	Nikola Jokic	C	9.6	5.8	3.8
	Russell Westbrook	PG	6.4	2.5	3.8
	Bam Adebayo	C	3.1	-0.5	3.6
	Jusuf Nurkic	C	5.2	1.5	3.6
source: basketball-reference.com via nbastatR
* Players with 500+ minutes. † Box Plus/Minus; a box score estimate of the points per 100 possessions that a player contributed above a league-average player, translated to an average team. ‡ Offensive Box Plus/Minus. § Defensive Box Plus/Minus.

Highcharts

Messing around with highcharts courtesy of Joshua Kunst’s {highcharter} package.

library(highcharter)
#> Highcharts (www.highcharts.com) is a Highsoft software product which is
#> not free for commercial and Governmental use

hchart(adv_player_stats, "scatter", hcaes(x = "ratioOBPM", y = "ratioDBPM", group = "position", name = "namePlayer", OBPM = "ratioOBPM", DBPM = "ratioDBPM", position = "position")) %>%
  hc_tooltip(pointFormat = "<b>{point.name}</b><br />OBPM: {point.OBPM}<br />DBPM: {point.DBPM}") %>%
  hc_title(text = "Offensive vs. Defensive Box Plus/Minus") %>%
  hc_subtitle(text = "NBA 2018-2019 Season") %>%
  hc_credits(enabled = TRUE,
             text = "data via nbastatR",
             style = list(
               fontSize = "10px"
               )
             ) %>%
  hc_add_theme(hc_theme_538())

hchart(adv_player_stats, "scatter", hcaes(x = "ratioOWS", y = "ratioDWS", group = "position", name = "namePlayer", OWS = "ratioOWS", DWS = "ratioDWS", position = "position")) %>%
  hc_tooltip(pointFormat = "<b>{point.name}</b><br />OWS: {point.OWS}<br />DWS: {point.DWS}") %>%
  hc_title(text = "Offensive vs. Defensive Win Shares") %>%
  hc_subtitle(text = "NBA 2018-2019 Season") %>%
  hc_credits(enabled = TRUE,
             text = "data via nbastatR",
             style = list(
               fontSize = "10px"
               )
             ) %>%
  hc_add_theme(hc_theme_economist())

hchart(adv_player_stats, "scatter", 
       hcaes(x = "pctTrueShooting", y = "ratioPER",
             name = "namePlayer", TS = "pctTrueShooting", 
             PER = "ratioPER", position = "position")) %>%
  hc_tooltip(pointFormat = "<b>{point.name}</b><br />TS%: {point.TS}<br />PER: {point.PER}<br />Position: {point.position}") %>%
  hc_title(text = "True Shooting % vs Player Efficiency Rating") %>%
  hc_subtitle(text = "NBA 2018-2019 Season") %>%
  hc_credits(enabled = TRUE,
             text = "data via nbastatR",
             style = list(
               fontSize = "14px"
               )
             ) %>%
  hc_add_theme(hc_theme_chalk(
    plotOptions = list(
      scatter = list(
        marker = list(radius = 4,
                      fillOpacity = 0.3) # actually this does nothing
        )
      )
    )
  )

hc <- hchart(adv_player_stats, "scatter", hcaes(x = "ratioOWS", y = "ratioDWS", group = "position", name = "namePlayer", OWS = "ratioOWS", DWS = "ratioDWS", Position = "position")) %>%
  hc_tooltip(pointFormat = "<b>{point.name}</b><br />OWS: {point.OWS}<br />DWS: {point.DWS}") %>%
  hc_title(text = "Offensive vs. Defensive Win Shares") %>%
  hc_subtitle(text = "NBA 2018-2019 Season") %>%
  hc_credits(enabled = TRUE,
             text = "by @dataandme data via nbastatR",
             href = "https://github.com/abresler/nbastatR",
             style = list(
               fontSize = "10px",
               color = "#4a4a4a"
               )
             ) 

hc2 <- hchart(adv_player_stats, "scatter", 
       hcaes(x = "ortg", y = "drtg", group = "position",
             name = "namePlayer", ortg = "ortg", 
             drtg = "drtg", position = "position")) %>%
  hc_tooltip(pointFormat = "<b>{point.name}</b><br />ORTG: {point.ortg}<br />DRTG: {point.drtg}<br />Position: {point.position}") %>%
  hc_title(text = "Offensive vs. Defensive Rating") %>%
  hc_subtitle(text = "NBA 2018-2019 Season") %>%
  hc_credits(enabled = TRUE,
             text = "data via nbastatR",
             style = list(
               fontSize = "14px"
               )
             )

Playing with palettes and themeing…

Here’s a figure that Highcharts had in its documentation that I very much wish I’d found before I started mucking about with making my own themes.

Highcharts: Design and Style - Chart positioning

hc %>%
  hc_add_theme(hrbrish)

hc2 %>%
  hc_add_theme(hc_theme_bloom())

Getting pomological 🍅

Add pomological palettes from Garrick Aden-Buie’s {ggpomological} package:

# source: https://github.com/gadenbuie/ggpomological/blob/master/R/scale_pomological.R
pomological_palette <- c(
   "#c03728" #red
  ,"#919c4c" #green darkish
  ,"#fd8f24" #orange brighter
  ,"#f5c04a" #yelloww
  ,"#e68c7c" #pink
  ,"#828585" #light grey
  ,"#c3c377" #green light
  ,"#4f5157" #darker blue/grey
  ,"#6f5438" #lighter brown
)

pomological_base <- list(
  "paper"       = "#fffeea",
  "paper_alt"   = "#f8eed1",
  "light_line"  = "#efe1c6",
  "medium_line" = "#a89985",
  "darker_line" = "#6b452b",
  "black"       = "#3a3e3f",
  "dark_blue"   = "#2b323f"
)

#' Pomological Color and Fill Scales
#' 
#' Color scales based on the USDA Pomological Watercolors paintings.
#' 
#' @references https://usdawatercolors.nal.usda.gov/pom
#' @seealso [ggplot2::scale_colour_discrete] [ggplot2::scale_fill_discrete]
#' @inheritDotParams ggplot2::discrete_scale
#' @name scale_pomological
NULL
#> NULL

pomological_pal <- function() scales::manual_pal(pomological_palette)

#' @rdname scale_pomological
#' @export
scale_colour_pomological <- function(...) ggplot2::discrete_scale("colour", "pomological", pomological_pal(), ...)

#' @rdname scale_pomological
#' @export
scale_color_pomological <- scale_colour_pomological

#' @rdname scale_pomological
#' @export
scale_fill_pomological <- function(...) ggplot2::discrete_scale('fill', 'pomological', pomological_pal(), ...)

#' Olden timey theme for highcharts
#' 
#' @param ... Named argument to modify the theme
#' 
#' @examples
#' 
#' highcharts_demo() %>% 
#'   hc_add_theme(hc_theme_oldentimey())
#' 
#' @importFrom grDevices colorRampPalette 
#' @export
hc_theme_oldentimey <- function(...){
  
  theme <-   
  list(
    colors = pomological_palette,
    chart = list(
      divBackgroundImage = "https://raw.githubusercontent.com/gadenbuie/ggpomological/master/inst/images/pomological_background.png",
      backgroundColor = "transparent",
      plotBorderColor = pomological_base$paper,
      colorAxis = list(
        gridLineColor = pomological_base$darker_line
      ),
      style = list(
        fontFamily = "Homemade Apple",
        color = pomological_base$dark_blue
      )
    ),
    plotOptions = list(
      scatter = list(
        marker = list(
          radius = 4
        )
      )
    ),
    title = list(
      style = list(
        fontSize = "22px",
        color = pomological_base$dark_blue
      )
    ),
    subtitle = list(
      style = list(
        fontSize = "18px",
        color = pomological_base$dark_blue
      )
    ),
    legend = list(
      enabled = TRUE,
      itemStyle = list(
        fontSize = "14px",
        fontWeight = "light",
        color = pomological_base$dark_blue
      )
    ),
   credits = list(
    enabled = TRUE,
    position = list(
      x = -15,  # highcharts default: -10
      y = -10   # highchart default: -5
    ),
    style = list(
      fontFamily = "Mr De Haviland",
      fontSize = "18px",
      color = pomological_base$dark_blue,
      fontWeight = "light"
    ),
    xAxis = list(
      lineWidth = 1,
      tickWidth = 1,
      gridLineColor = "transparent",
      labels = list(
        enabled = TRUE,
        style = list(
          color = pomological_base$dark_blue,
          fontSize = "18px"
        )
      ),
      # x-axis title
      title = list(
        enabled = TRUE,
        style = list(
          color = pomological_base$dark_blue,
          fontSize = "18px"
          
        )
      )
    ),
    yAxis = list(
      lineWidth = 1,
      tickWidth = 1,
      gridLineColor = "transparent",
      labels = list(
        enabled = TRUE,
        style = list(
          color = pomological_base$dark_blue,
          fontSize = "18px"
        )
      ),
      # y-axis title
      title = list(
        enabled = TRUE,
        style = list(
          color = pomological_base$dark_blue,
          fontSize = "18px"
          
        )
      )
    ),
    tooltip = list(
      backgroundColor = "#f8eed1",
      style = list(
        color = pomological_base$dark_blue,
        fontSize = "18px",
        padding = "10px"
      )
    )
  ))
  
  theme <- structure(theme, class = "hc_theme")
  
  if (length(list(...)) > 0) {
    theme <- hc_theme_merge(
      theme,
      hc_theme(...)
    )
  } 
  
  theme
}

hc2 %>%
  hc_add_theme(hc_theme_oldentimey())

Since the scattered points don’t take an alpha param, let’s see if we can make things work using rgba colours (in this example we’ll set opacity to 70%)³:

pom_pal_70 <- c(
  "rgba(192, 55, 40, 0.7)", # red
  "rgba(145, 156, 76, 0.7)", # green darkish
  "rgba(253, 143, 36, 0.7)", # orange brighter
  "rgba(245, 192, 74, 0.7)", # yellow
  "rgba(230, 140, 124, 0.7)", # pink
  "rgba(130, 133, 133, 0.7)", # light grey
  "rgba(195, 195, 119, 0.7)", # green light
  "rgba(79, 81, 87, 0.7)", # darker blue/grey
  "rgba(111, 84, 56, 0.7)" # lighter brown
)

Note: this could easily be a function where you pass in the alpha as a parameter and modify an rgb() color to become an rgba() one with the appropriate setting.

Actually, turns out there’s a function that would’ve basically done this for me… You can start off with Garrick’s pomological_palette, and then use col2rgb() to convert the colours appropriately.

pomological_palette <- c(
   "#c03728" #red
  ,"#919c4c" #green darkish
  ,"#fd8f24" #orange brighter
  ,"#f5c04a" #yelloww
  ,"#e68c7c" #pink
  ,"#828585" #light grey
  ,"#c3c377" #green light
  ,"#4f5157" #darker blue/grey
  ,"#6f5438" #lighter brown
)

rgb_pom_pal <- as_tibble(grDevices::col2rgb(pomological_palette), .name_repair = "universal")
#> New names:
#> * `` -> ...1
#> * `` -> ...2
#> * `` -> ...3
#> * `` -> ...4
#> * `` -> ...5
#> * … and 4 more problems

rgb_pom_pal <- as.data.frame(rgb_pom_pal)


rownames(rgb_pom_pal) <- c("red", "green", "blue")

rgb_pom_pal <- rgb_pom_pal %>% 
  rownames_to_column()

Just one minor problem…the shape.

rgb_pom_pal <- rgb_pom_pal %>%
  gather(color, measure, ...1:...9)

# note, obviously you could dynamically deal with opacity, 
# and not just hard-code it...
rgb_pom_pal <- rgb_pom_pal %>% 
  spread(rowname, measure) %>%
  select(one_of(c("color", "red", "green", "blue"))) %>%
  mutate("rgb" = glue::glue("rgb({red}, {green}, {blue})"),
         "rgba" = glue::glue("rgba({red}, {green}, {blue}, 0.8)"))

rgb_pom_pal
#>   color red green blue                rgb                     rgba
#> 1  ...1 192    55   40   rgb(192, 55, 40)   rgba(192, 55, 40, 0.8)
#> 2  ...2 145   156   76  rgb(145, 156, 76)  rgba(145, 156, 76, 0.8)
#> 3  ...3 253   143   36  rgb(253, 143, 36)  rgba(253, 143, 36, 0.8)
#> 4  ...4 245   192   74  rgb(245, 192, 74)  rgba(245, 192, 74, 0.8)
#> 5  ...5 230   140  124 rgb(230, 140, 124) rgba(230, 140, 124, 0.8)
#> 6  ...6 130   133  133 rgb(130, 133, 133) rgba(130, 133, 133, 0.8)
#> 7  ...7 195   195  119 rgb(195, 195, 119) rgba(195, 195, 119, 0.8)
#> 8  ...8  79    81   87    rgb(79, 81, 87)    rgba(79, 81, 87, 0.8)
#> 9  ...9 111    84   56   rgb(111, 84, 56)   rgba(111, 84, 56, 0.8)

After all of this, I discovered there’s actually a function, plotly::toRGB(), which deals with the rgb matrix from grDevices:col2rgb(), and outputs in the format "rgba(70,130,180,1)". So, in the end that’s probably the best bet.

plotly::toRGB(x = "red", alpha = 0.8)
#> [1] "rgba(255,0,0,0.8)"
plotly::toRGB(x = "#c03728", alpha = 0.8)
#> [1] "rgba(192,55,40,0.8)"

All of that code above could’ve basically been:

rgba_pomological_pal <- plotly::toRGB(pomological_palette, alpha = 0.8)

hc_theme_oldentimey_alpha <- function(...){
  
  theme <-   
  list(
    colors = rgba_pomological_pal,
    chart = list(
      divBackgroundImage = "https://raw.githubusercontent.com/gadenbuie/ggpomological/master/inst/images/pomological_background.png",
      spacingTop = 30,
      backgroundColor = "transparent",
      plotBorderColor = pomological_base$paper,
      colorAxis = list(
        gridLineColor = pomological_base$darker_line
      ),
      style = list(
        fontFamily = "Homemade Apple",
        color = pomological_base$dark_blue
      )
    ),
    plotOptions = list(
      scatter = list(
        marker = list(
          radius = 4
        )
      )
    ),
    title = list(
      style = list(
        fontSize = "22px",
        color = pomological_base$dark_blue
      )
    ),
    subtitle = list(
      style = list(
        fontSize = "18px",
        color = pomological_base$dark_blue
      )
    ),
    legend = list(
      enabled = TRUE,
      itemStyle = list(
        fontSize = "14px",
        fontWeight = "light",
        color = pomological_base$dark_blue
      )
    ),
   credits = list(
    enabled = TRUE,
    position = list(
      x = -15,  # highcharts default: -10
      y = -10   # highchart default: -5
    ),
    style = list(
      fontFamily = "Mr De Haviland",
      fontSize = "18px",
      color = pomological_base$dark_blue,
      fontWeight = "light"
    ),
    xAxis = list(
      lineWidth = 1,
      tickWidth = 1,
      gridLineColor = "transparent",
      labels = list(
        enabled = TRUE,
        style = list(
          color = pomological_base$dark_blue,
          fontSize = "18px"
        )
      ),
      # x-axis title
      title = list(
        enabled = TRUE,
        style = list(
          color = pomological_base$dark_blue,
          fontSize = "18px"
          
        )
      )
    ),
    yAxis = list(
      lineWidth = 1,
      tickWidth = 1,
      gridLineColor = "transparent",
      labels = list(
        enabled = TRUE,
        style = list(
          color = pomological_base$dark_blue,
          fontSize = "18px"
        )
      ),
      # y-axis title
      title = list(
        enabled = TRUE,
        style = list(
          color = pomological_base$dark_blue,
          fontSize = "18px"
          
        )
      )
    ),
    tooltip = list(
      backgroundColor = "#f8eed1",
      style = list(
        color = pomological_base$dark_blue,
        fontSize = "18px",
        padding = "10px"
      )
    )
  ))
  
  theme <- structure(theme, class = "hc_theme")
  
  if (length(list(...)) > 0) {
    theme <- hc_theme_merge(
      theme,
      hc_theme(...)
    )
  } 
  
  theme
}

hc %>%
  hc_add_theme(hc_theme_oldentimey_alpha())