Graphics utilizing tracking data to display Bones Hyland’s shooting from the ’22 season. Will need to attack the basket more with larger role next season to create more qaulity opportunities for himself and others, but range is already a proven asset.

library(ggplot2)
library(tidyverse)
## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.1 ──
## ✓ tibble  3.1.4     ✓ dplyr   1.0.7
## ✓ tidyr   1.2.0     ✓ stringr 1.4.0
## ✓ readr   2.0.1     ✓ forcats 0.5.1
## ✓ purrr   0.3.4
## Warning: package 'tidyr' was built under R version 4.1.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## x dplyr::filter() masks stats::filter()
## x dplyr::lag()    masks stats::lag()
library(nbastatR)
## Warning: replacing previous import 'dplyr::collapse' by 'glue::collapse' when
## loading 'nbastatR'
## Warning: replacing previous import 'curl::handle_reset' by 'httr::handle_reset'
## when loading 'nbastatR'
## Warning: replacing previous import 'httr::timeout' by 'memoise::timeout' when
## loading 'nbastatR'
## Warning: replacing previous import 'magrittr::set_names' by 'purrr::set_names'
## when loading 'nbastatR'
## Warning: replacing previous import 'jsonlite::flatten' by 'purrr::flatten' when
## loading 'nbastatR'
## Warning: replacing previous import 'curl::parse_date' by 'readr::parse_date'
## when loading 'nbastatR'
## Warning: replacing previous import 'purrr::list_along' by 'rlang::list_along'
## when loading 'nbastatR'
## Warning: replacing previous import 'purrr::invoke' by 'rlang::invoke' when
## loading 'nbastatR'
## Warning: replacing previous import 'purrr::flatten_raw' by 'rlang::flatten_raw'
## when loading 'nbastatR'
## Warning: replacing previous import 'purrr::modify' by 'rlang::modify' when
## loading 'nbastatR'
## Warning: replacing previous import 'purrr::as_function' by 'rlang::as_function'
## when loading 'nbastatR'
## Warning: replacing previous import 'purrr::flatten_dbl' by 'rlang::flatten_dbl'
## when loading 'nbastatR'
## Warning: replacing previous import 'jsonlite::unbox' by 'rlang::unbox' when
## loading 'nbastatR'
## Warning: replacing previous import 'purrr::flatten_lgl' by 'rlang::flatten_lgl'
## when loading 'nbastatR'
## Warning: replacing previous import 'purrr::flatten_int' by 'rlang::flatten_int'
## when loading 'nbastatR'
## Warning: replacing previous import 'purrr::%@%' by 'rlang::%@%' when loading
## 'nbastatR'
## Warning: replacing previous import 'purrr::flatten_chr' by 'rlang::flatten_chr'
## when loading 'nbastatR'
## Warning: replacing previous import 'purrr::splice' by 'rlang::splice' when
## loading 'nbastatR'
## Warning: replacing previous import 'purrr::flatten' by 'rlang::flatten' when
## loading 'nbastatR'
## Warning: replacing previous import 'purrr::prepend' by 'rlang::prepend' when
## loading 'nbastatR'
## Warning: replacing previous import 'readr::guess_encoding' by
## 'rvest::guess_encoding' when loading 'nbastatR'
## Warning: replacing previous import 'magrittr::extract' by 'tidyr::extract' when
## loading 'nbastatR'
## Warning: replacing previous import 'rlang::as_list' by 'xml2::as_list' when
## loading 'nbastatR'
library(devtools)
## Loading required package: usethis
library(extrafont)
## Registering fonts with R
library(cowplot)
library(paletteer)
library(rstatix)
## 
## Attaching package: 'rstatix'
## The following object is masked from 'package:stats':
## 
##     filter
library(ggpubr)
## 
## Attaching package: 'ggpubr'
## The following object is masked from 'package:cowplot':
## 
##     get_legend
library(grid)
library(gridExtra)
## 
## Attaching package: 'gridExtra'
## The following object is masked from 'package:dplyr':
## 
##     combine
library(crosstalk)
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
library(janitor)
## 
## Attaching package: 'janitor'
## The following object is masked from 'package:rstatix':
## 
##     make_clean_names
## The following objects are masked from 'package:stats':
## 
##     chisq.test, fisher.test
library(tidyverse)
library(reactable)
## Warning: package 'reactable' was built under R version 4.1.2
library(rvest)
## 
## Attaching package: 'rvest'
## The following object is masked from 'package:readr':
## 
##     guess_encoding
library(gt)
bballref_url <- read_html( "https://www.basketball-reference.com/players/h/hylanbo01/shooting/2022")
bones_bballref <- bballref_url %>%
  html_node( "table") %>%
  html_table(fill = TRUE) 

bones_bballref %>%
  reactable( filterable = TRUE,
             searchable = TRUE,
             highlight = TRUE)

Can filter by team, shot type, quarter, month, home vs away, win or loss, shot distance, and game situations such as score or time left using value column.

#court
circle_points = function(center = c(0, 0), radius = 1, npoints = 360) {
  angles = seq(0, 2 * pi, length.out = npoints)
  return(data_frame(x = center[1] + radius * cos(angles),
                    y = center[2] + radius * sin(angles)))
}

width = 50
height = 94 / 2
key_height = 19
inner_key_width = 12
outer_key_width = 16
backboard_width = 6
backboard_offset = 4
neck_length = 0.5
hoop_radius = 0.75
hoop_center_y = backboard_offset + neck_length + hoop_radius
three_point_radius = 23.75
three_point_side_radius = 22
three_point_side_height = 14

court_themes = list(
  light = list(
    court = 'floralwhite',
    lines = '#999999',
    text = '#222222',
    made = '#00bfc4',
    missed = '#f8766d',
    hex_border_size = 1,
    hex_border_color = "#000000"
  ),
  dark = list(
    court = '#000004',
    lines = '#999999',
    text = '#f0f0f0',
    made = '#00bfc4',
    missed = '#f8766d',
    hex_border_size = 0,
    hex_border_color = "#000000"
  )
)


plot_court = function(court_theme = court_themes$light, use_short_three = FALSE) {
  if (use_short_three) {
    three_point_radius = 22
    three_point_side_height = 0
  }
  
  court_points = data_frame(
    x = c(width / 2, width / 2, -width / 2, -width / 2, width / 2),
    y = c(height, 0, 0, height, height),
    desc = "perimeter"
  )
  
  court_points = bind_rows(court_points , data_frame(
    x = c(outer_key_width / 2, outer_key_width / 2, -outer_key_width / 2, -outer_key_width / 2),
    y = c(0, key_height, key_height, 0),
    desc = "outer_key"
  ))
  
  court_points = bind_rows(court_points , data_frame(
    x = c(-backboard_width / 2, backboard_width / 2),
    y = c(backboard_offset, backboard_offset),
    desc = "backboard"
  ))
  
  court_points = bind_rows(court_points , data_frame(
    x = c(0, 0), y = c(backboard_offset, backboard_offset + neck_length), desc = "neck"
  ))
  
  foul_circle = circle_points(center = c(0, key_height), radius = inner_key_width / 2)
  
  foul_circle_top = filter(foul_circle, y > key_height) %>%
    mutate(desc = "foul_circle_top")
  
  foul_circle_bottom = filter(foul_circle, y < key_height) %>%
    mutate(
      angle = atan((y - key_height) / x) * 180 / pi,
      angle_group = floor((angle - 5.625) / 11.25),
      desc = paste0("foul_circle_bottom_", angle_group)
    ) %>%
    filter(angle_group %% 2 == 0) %>%
    select(x, y, desc)
  
  hoop = circle_points(center = c(0, hoop_center_y), radius = hoop_radius) %>%
    mutate(desc = "hoop")
  
  restricted = circle_points(center = c(0, hoop_center_y), radius = 4) %>%
    filter(y >= hoop_center_y) %>%
    mutate(desc = "restricted")
  
  three_point_circle = circle_points(center = c(0, hoop_center_y), radius = three_point_radius) %>%
    filter(y >= three_point_side_height, y >= hoop_center_y)
  
  three_point_line = data_frame(
    x = c(three_point_side_radius, three_point_side_radius, three_point_circle$x, -three_point_side_radius, -three_point_side_radius),
    y = c(0, three_point_side_height, three_point_circle$y, three_point_side_height, 0),
    desc = "three_point_line"
  )
  
  court_points = bind_rows(
    court_points,
    foul_circle_top,
    foul_circle_bottom,
    hoop,
    restricted,
    three_point_line
  )
  
  
  court_points <- court_points
  
  ggplot() +
    geom_path(
      data = court_points,
      aes(x = x, y = y, group = desc),
      color = court_theme$lines
    ) +
    coord_fixed(ylim = c(0, 45), xlim = c(-25, 25)) +
    theme_minimal(base_size = 22) +
    theme(
      text = element_text(color = court_theme$text),
      plot.background = element_rect(fill = 'floralwhite', color = 'floralwhite'),
      panel.background = element_rect(fill = court_theme$court, color = court_theme$court),
      panel.grid = element_blank(),
      panel.border = element_blank(),
      axis.text = element_blank(),
      axis.title = element_blank(),
      axis.ticks = element_blank(),
      legend.background = element_rect(fill = court_theme$court, color = court_theme$court),
      legend.margin = margin(-1, 0, 0, 0, unit = "lines"),
      legend.position = "bottom",
      legend.key = element_blank(),
      legend.text = element_text(size = rel(1.0))
    )
}

plot_court(court_themes$light)
## Warning: `data_frame()` was deprecated in tibble 1.1.0.
## Please use `tibble()` instead.

#clean and pull data

Sys.setenv("VROOM_CONNECTION_SIZE" = 131072 * 2)


nugs_shots <- teams_shots(
  teams = "Denver Nuggets",
  seasons = 2022,
  season_types = "Regular Season"
)
## Warning: `funs()` was deprecated in dplyr 0.8.0.
## Please use a list of either functions or lambdas: 
## 
##   # Simple named list: 
##   list(mean = mean, median = median)
## 
##   # Auto named with `tibble::lst()`: 
##   tibble::lst(mean, median)
## 
##   # Using lambdas
##   list(~ mean(., trim = .2), ~ median(., na.rm = TRUE))
## Denver Nuggets 2021-22 shot data
bones_22 <- nugs_shots %>%
  filter( namePlayer == "Bones Hyland") %>%
  mutate( x = as.numeric(as.character(locationX))/10,
          y = as.numeric(as.character(locationY))/ 10 + hoop_center_y,
          dateGame = as.numeric(dateGame))
bones_22$x <- bones_22$x * -1

bones_shared <- SharedData$new( bones_22, key = ~typeAction, group = "Shot Type")
#heat
palette <- paletteer_d( "RColorBrewer::YlOrRd", direction = -1 )

bones_heat <- plot_court() + 
  geom_density_2d_filled(bones_22, mapping = aes( x = x, y = y,
                                                  fill = ..level..,),
                         contour_var = "ndensity" ,
                         breaks = seq(0.1,1.0, length.out = 10),
                         alpha = .75)  +
  scale_fill_manual( values = c(palette), aesthetics = c("fill", "color")) +
  scale_x_continuous( limits = c(-27.5, 27.5)) +
  scale_y_continuous( limits = c(0, 45)) + 
  theme( legend.position = "none", 
         plot.title = element_text( hjust = .5 , size = 22,
                                    family = "Comic Sans MS",
                                    face = "bold",
                                    vjust = -4),
         plot.subtitle = element_text( hjust = .5, size = 10,
                                       family = "Comic Sans MS",
                                       face = "bold",
                                       vjust = -5),
         legend.direction = "horizontal",
         legend.title = element_blank(),
         legend.text = element_text( hjust = .5, size = 10,
                                     family = "Comic Sans MS",
                                     face = "bold",
                                     color = "white"),
         plot.caption = element_text(hjust = .5, size = 6,
                                     family = "Comic Sans MS",
                                     face = "bold",
                                     color = "lightgrey",
                                     vjust = 8)
         ) +
  labs( title = "Bones Shot Heatmap",
        subtitle = "2021-2022 season")
#shot chart
bones <- plot_court() + 
  geom_point( data = bones_shared, aes( x = x , y = y,
                                    color = isShotMade,
                                    fill = isShotMade),
              size = 2, shape = 21, stroke = .2) +
  scale_color_manual( values = c("green4", "red3"), 
                      aesthetics = "color",
                      breaks = c("TRUE", "FALSE"),
                      labels = c("Made", "Missed")) +
  scale_fill_manual( values = c("green2", "grey20"),
                     aesthetics = "fill",
                     breaks = c("TRUE", "FALSE"),
                     labels = c("Made", "Missed")) +
  scale_x_continuous( limits = c(-27.5, 27.5)) +
  scale_y_continuous( limits = c(0,45)) +
  theme( legend.title = element_blank()) +
  ggtitle( label = "Bones Shot Chart") 

ggplotly( bones) %>% 
  highlight( selectize = TRUE) %>%
  hide_legend()
## Setting the `off` event (i.e., 'plotly_doubleclick') to match the `on` event (i.e., 'plotly_click'). You can change this default via the `highlight()` function.
attempts <- sum( bones_22$isShotAttempted)
makes <- sum(bones_22$isShotMade)
bones_22_table <- rbind( makes, attempts)
  

table <- ggtexttable( bones_22_table,
                      theme = ttheme("blank", base_size = 6.5),
                      rows = c("makes", "attempts"))

combined_bones <- arrangeGrob( bones_heat, table, 
                              heights = c(10,2))
## Warning: Removed 2 rows containing non-finite values (stat_density2d_filled).
## Warning: Removed 3 row(s) containing missing values (geom_path).
showGrob( combined_bones)

bones_22 %>%
  mutate( n = length(unique(typeAction))) %>%
  filter( typeAction == c("Jump Shot", 
                          "Pullup Jump shot",
                          "Step Back Jump shot",
                          "Driving Layup Shot",
                          "Running Dunk Shot",
                          "Running Layup Shot")) %>%
  ggplot(aes( x = typeAction)) + geom_bar()+
  theme(axis.text.x = element_blank())+
  theme_grey()
## Warning in typeAction == c("Jump Shot", "Pullup Jump shot", "Step Back Jump
## shot", : longer object length is not a multiple of shorter object length

bones_22 %>% ggplot( aes( x = zoneRange))+
  geom_bar()+
  theme_grey()

Sys.setenv("VROOM_CONNECTION_SIZE" = 131072 * 2)


bones_22 <- teams_shots(
  teams = "Denver Nuggets",
  seasons = 2022,
  season_types = "Regular Season"
) %>%
  filter( namePlayer == "Bones Hyland")
## Denver Nuggets 2021-22 shot data
bones_22 %>%
  select( yearSeason, namePlayer, typeEvent, typeAction, typeShot, dateGame, slugTeamAway,zoneBasic, nameZone, zoneRange, distanceShot,isShotMade ) %>%
  reactable( filterable = TRUE,
             searchable = TRUE, 
             highlight = TRUE)