Improved Shot Charts
Dylan Kinion
2022-10-13
library(tidyverse)
library(nbastatR)
library(plyr)
library(scales)
library(dplyr)
library(paletteer)
library(cowplot)
library(grid)
library(gridExtra)
library(png)
library(RCurl)
library(crosstalk)
library(plotly)
library(rpubs)
Sys.setenv("VROOM_CONNECTION_SIZE" = 131072 * 2)#court function from owen phillips
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.position = "bottom",
legend.key = element_blank(),
legend.text = element_text(size = rel(1.0))
)
}
pc <- plot_court(court_themes$light)#allow for larger data pulls
Sys.setenv("VROOM_CONNECTION_SIZE" = 131072 * 2)
#shot data from nbastatR
nugs_shots <- teams_shots(
teams = "Denver Nuggets",
seasons = 2022,
season_types = "Regular Season"
)## Denver Nuggets 2021-22 shot data#clean data for plot_court
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#use nbastatR to get player headshots
active_player_photos <- nba_players() %>%
filter( isActive == "TRUE") %>%
select(namePlayer,
idPlayer,
urlPlayerHeadshot,
urlPlayerActionPhoto)#remove backcourt shots
shotData <- bones_22 %>%
filter( nameZone != "Back Court") %>%
mutate( isShotAttempted =
case_when(
isShotAttempted == "TRUE" ~ 1,
TRUE ~ 0
),
isShotMade =
case_when(
isShotMade == "TRUE" ~ 1,
TRUE ~ 0
)) %>%
right_join(active_player_photos)
#find fg% by zone
abb3 <- shotData %>%
filter( zoneBasic == "Above the Break 3") %>%
summarise( accuracy = mean(isShotMade)) %>%
mutate_at(vars(accuracy), funs(round(.,4)))
abb3 <- abb3 * 100
lc3 <- shotData %>%
filter( zoneBasic == "Left Corner 3") %>%
summarise( accuracy = mean(isShotMade))%>%
mutate_at(vars(accuracy), funs(round(.,4)))
lc3 <- lc3 * 100
mr <- shotData %>%
filter( zoneBasic == "Mid-Range") %>%
summarise( accuracy = mean(isShotMade))%>%
mutate_at(vars(accuracy), funs(round(.,4)))
mr <- mr * 100
rc3 <- shotData %>%
filter( zoneBasic == "Right Corner 3") %>%
summarise( accuracy = mean(isShotMade))%>%
mutate_at(vars(accuracy), funs(round(.,4)))
rc3 <- rc3 * 100
ip <- shotData %>%
filter( zoneBasic == "In The Paint (Non-RA)") %>%
summarise( accuracy = mean(isShotMade))%>%
mutate_at(vars(accuracy), funs(round(.,4)))
ip <- ip * 100
ra <- shotData %>%
filter( zoneBasic == "Restricted Area") %>%
summarise( accuracy = mean(isShotMade))%>%
mutate_at(vars(accuracy), funs(round(.,4)))
ra <- ra * 100#heat map
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,
with FG% included by zone")
#prepare headshot
headshot <- shotData %>%
select(urlPlayerHeadshot) %>%
.[1,1]
playerImg <- rasterGrob(readPNG(getURLContent(headshot)),
width = unit(.15, "npc"))
#combine heatmap with fg% by zones
bones_heat +
geom_text(data = ra , x = 0 , y = 7, label = ra) +
geom_text(data = ip, x = 0 , y = 15, label = ip) +
geom_text(data = abb3, x = 0 , y = 33, label = abb3) +
geom_text(data = mr, x = 0 , y = 24, label = mr) +
geom_text(data = rc3, x = -22, y = 7, label = rc3) +
geom_text(data = lc3, x = 22, y = 7, label = lc3)
#add player photo
pushViewport(viewport(x = unit(0.9, "npc"), y = unit(0.8, "npc")))
print(grid.draw(playerImg), newpage=FALSE)
## NULL- Brighter areas equate to higher a higher quantity
#create shared data object in order to filter chart
bones_shared <- SharedData$new( bones_22, key = ~typeAction, group = "Shot Type")
#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")
#convert to plotly to allow for filtering by shot type
ggplotly( bones) %>%
highlight( selectize = TRUE) %>%
hide_legend()- Ability to filter by shot type
#zone identifier
plot_court(court_themes$light)+
geom_text(data = ra , x = 0 , y = 7, label = "Restricted Area") +
geom_text(data = ip, x = 0 , y = 15, label = "Paint (nonRA)") +
geom_text(data = abb3, x = 0 , y = 33, label = "Above the break 3") +
geom_text(data = mr, x = 0 , y = 24, label = "Mid-Range") +
geom_text(data = rc3, x = -19, y = 7, label = "Right Corner 3") +
geom_text(data = lc3, x = 19, y = 7, label = "Left Corner 3") +
ggtitle("Zones")
Session Info
sessionInfo()## R version 4.2.1 (2022-06-23)
## Platform: x86_64-apple-darwin17.0 (64-bit)
## Running under: macOS Big Sur ... 10.16
##
## Matrix products: default
## BLAS: /Library/Frameworks/R.framework/Versions/4.2/Resources/lib/libRblas.0.dylib
## LAPACK: /Library/Frameworks/R.framework/Versions/4.2/Resources/lib/libRlapack.dylib
##
## locale:
## [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
##
## attached base packages:
## [1] grid stats graphics grDevices utils datasets methods
## [8] base
##
## other attached packages:
## [1] rpubs_0.2.2 plotly_4.10.0 crosstalk_1.2.0 RCurl_1.98-1.9
## [5] png_0.1-7 gridExtra_2.3 cowplot_1.1.1 paletteer_1.4.1
## [9] scales_1.2.1 plyr_1.8.7 nbastatR_0.1.151 forcats_0.5.2
## [13] stringr_1.4.1 dplyr_1.0.10 purrr_0.3.4 readr_2.1.3
## [17] tidyr_1.2.1 tibble_3.1.8 ggplot2_3.3.6 tidyverse_1.3.2
##
## loaded via a namespace (and not attached):
## [1] bitops_1.0-7 fs_1.5.2 lubridate_1.8.0
## [4] bit64_4.0.5 httr_1.4.4 tools_4.2.1
## [7] backports_1.4.1 bslib_0.4.0 utf8_1.2.2
## [10] R6_2.5.1 DBI_1.1.3 lazyeval_0.2.2
## [13] colorspace_2.0-3 withr_2.5.0 tidyselect_1.1.2
## [16] bit_4.0.4 curl_4.3.2 compiler_4.2.1
## [19] cli_3.4.1 rvest_1.0.3 xml2_1.3.3
## [22] isoband_0.2.5 labeling_0.4.2 prismatic_1.1.1
## [25] sass_0.4.2 digest_0.6.29 rmarkdown_2.16
## [28] pkgconfig_2.0.3 htmltools_0.5.3 parallelly_1.32.1
## [31] highr_0.9 dbplyr_2.2.1 fastmap_1.1.0
## [34] htmlwidgets_1.5.4 rlang_1.0.6 readxl_1.4.1
## [37] rstudioapi_0.14 shiny_1.7.2 farver_2.1.1
## [40] jquerylib_0.1.4 generics_0.1.3 jsonlite_1.8.2
## [43] vroom_1.6.0 googlesheets4_1.0.1 magrittr_2.0.3
## [46] Rcpp_1.0.9 munsell_0.5.0 fansi_1.0.3
## [49] lifecycle_1.0.2 furrr_0.3.1 stringi_1.7.8
## [52] yaml_2.3.5 MASS_7.3-57 promises_1.2.0.1
## [55] parallel_4.2.1 listenv_0.8.0 crayon_1.5.2
## [58] haven_2.5.1 hms_1.1.2 knitr_1.40
## [61] pillar_1.8.1 codetools_0.2-18 reprex_2.0.2
## [64] glue_1.6.2 evaluate_0.16 data.table_1.14.2
## [67] modelr_0.1.9 httpuv_1.6.6 vctrs_0.4.2
## [70] tzdb_0.3.0 cellranger_1.1.0 gtable_0.3.1
## [73] rematch2_2.1.2 future_1.28.0 assertthat_0.2.1
## [76] cachem_1.0.6 xfun_0.33 mime_0.12
## [79] xtable_1.8-4 broom_1.0.1 later_1.3.0
## [82] googledrive_2.0.0 viridisLite_0.4.1 gargle_1.2.1
## [85] memoise_2.0.1 globals_0.16.1 ellipsis_0.3.2