Michael Porter Jr. Heatmap
Dylan Kinion
2022-10-16
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(reactable)
library(reactablefmtr)
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)
#shot data from nbastatR
nugs_shots_21 <- teams_shots(
teams = "Denver Nuggets",
seasons = 2021,
season_types = "Regular Season",
return_message = FALSE
)
#clean data for plot_court
player_22 <- nugs_shots_21 %>%
filter( namePlayer == "Michael Porter Jr.") %>%
mutate( x = as.numeric(as.character(locationX))/10,
y = as.numeric(as.character(locationY))/ 10 + hoop_center_y,
dateGame = as.numeric(dateGame))
player_22$x <- player_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 <- player_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),
shots = sum(isShotAttempted),
makes = sum(isShotMade),
avg_distance = mean(distanceShot)) %>%
mutate_at(vars(accuracy, avg_distance), funs(round(.,4))) %>%
mutate( accuracy = accuracy * 100,
zone = "Above the Break 3")
lc3 <- shotData %>%
filter( zoneBasic == "Left Corner 3") %>%
summarise( accuracy = mean(isShotMade),
shots = sum(isShotAttempted),
makes = sum(isShotMade),
avg_distance = mean(distanceShot))%>%
mutate_at(vars(accuracy, avg_distance), funs(round(.,4))) %>%
mutate( accuracy = accuracy * 100,
zone = "Left Corner 3")
mr <- shotData %>%
filter( zoneBasic == "Mid-Range") %>%
summarise( accuracy = mean(isShotMade),
shots = sum(isShotAttempted),
makes = sum(isShotMade),
avg_distance = mean(distanceShot))%>%
mutate_at(vars(accuracy, avg_distance), funs(round(.,4))) %>%
mutate( accuracy = accuracy * 100,
zone = "Mid-Range")
rc3 <- shotData %>%
filter( zoneBasic == "Right Corner 3") %>%
summarise( accuracy = mean(isShotMade),
shots = sum(isShotAttempted),
makes = sum(isShotMade),
avg_distance = mean(distanceShot))%>%
mutate_at(vars(accuracy, avg_distance), funs(round(.,4))) %>%
mutate( accuracy = accuracy * 100,
zone = "Right Corner 3")
ip <- shotData %>%
filter( zoneBasic == "In The Paint (Non-RA)") %>%
summarise( accuracy = mean(isShotMade),
shots = sum(isShotAttempted),
makes = sum(isShotMade),
avg_distance = mean(distanceShot))%>%
mutate_at(vars(accuracy, avg_distance), funs(round(.,4))) %>%
mutate( accuracy = accuracy * 100,
zone = "In the Paint (non RA)")
ra <- shotData %>%
filter( zoneBasic == "Restricted Area") %>%
summarise( accuracy = mean(isShotMade),
shots = sum(isShotAttempted),
makes = sum(isShotMade),
avg_distance = mean(distanceShot))%>%
mutate_at(vars(accuracy, avg_distance), funs(round(.,4))) %>%
mutate( accuracy = accuracy * 100,
zone = "Restricted Area")c <- c("Favorite zone", "Best zone", "Worst zone")
d <- c("Above the Break 3", "Restricted Area", "In the Paint (non RA)")
bind_cols(c,d) %>%
rename( " " = '...2',
" " = '...1') %>%
reactable() %>%
add_title("Quick Summary")Quick Summary
Heatmap
#heat map
palette <- paletteer_d( "RColorBrewer::YlOrRd", direction = -1 )
player_heat <- plot_court() +
geom_density_2d_filled(player_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 = "MPJ Shot Heatmap",
subtitle = "2020-2021 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
player_heat +
geom_text(data = ra , x = 0 , y = 7, label = ra$accuracy) +
geom_text(data = ip, x = 0 , y = 15, label = ip$accuracy) +
geom_text(data = abb3, x = 0 , y = 33, label = abb3$accuracy) +
geom_text(data = mr, x = 0 , y = 24, label = mr$accuracy) +
geom_text(data = rc3, x = -22, y = 7, label = rc3$accuracy) +
geom_text(data = lc3, x = 22, y = 7, label = lc3$accuracy)
#add player photo
pushViewport(viewport(x = unit(0.9, "npc"), y = unit(0.8, "npc")))
print(grid.draw(playerImg), newpage=FALSE)
## NULLColored areas represent where a player takes most of their shots from (where they like to operate from). Brighter areas equate to a higher frequency.
Zones: Restricted Area, In the Paint(non-Restricted Area), Mid-Range, Above the Break 3, Left Corner 3, and Right Corner 3.
Left and right determined from the perspective of half-court facing the hoop.
Takeways
- Deadly from beyond the arc.
- More proven from above the break with 126 makes compared to 44 makes from the corners.
- Wouldn’t be surprised by lower FG% from corners in future due to variance’s impact on the small sample size, only took 91 attempts from the corners.
- Ratio of corner 3s to total shots: team = .087 MPJ = .111
- Elite finisher.
- Finished 16th in restricted area FG% out of 218 players that took at least 3 restricted area FGs per game.
- Highly efficient shot selection.
- 602 attempts from 3 and restricted area compared to just 213 attempts from mid-range and the paint (excluding the restricted area).
- Ability to space from corners and finish at elite levels makes him ideal to play alongside a ball dominant passer like Jokic. Not only does he provide space for Jokic to work, but also improves Jokic’s passing impact.
Shot Summary Tables
st <- bind_rows(ra, ip, mr, abb3, lc3, rc3) %>%
select(zone, makes, shots, accuracy, avg_distance) %>%
rename( 'accuracy %' = accuracy,
attempts = shots) %>%
mutate( 'pts/att' =
case_when(
zone == "Restricted Area" ~ (makes * 2)/attempts,
zone == "In the Paint (non RA)" ~ (makes * 2)/attempts,
zone == "Mid-Range" ~ (makes * 2)/attempts,
TRUE ~ (makes * 3)/attempts
)) %>%
mutate_at(vars('pts/att'), funs(round(.,4)))
team_21 <- nugs_shots_21 %>%
mutate( x = as.numeric(as.character(locationX))/10,
y = as.numeric(as.character(locationY))/ 10 + hoop_center_y,
dateGame = as.numeric(dateGame))
team_21$x <- team_21$x * -1
shotData_team <- team_21 %>%
filter( nameZone != "Back Court") %>%
mutate( isShotAttempted =
case_when(
isShotAttempted == "TRUE" ~ 1,
TRUE ~ 0
),
isShotMade =
case_when(
isShotMade == "TRUE" ~ 1,
TRUE ~ 0
))
abb3_t <- shotData_team %>%
filter( zoneBasic == "Above the Break 3") %>%
summarise( team_accuracy = mean(isShotMade),
team_shots = sum(isShotAttempted),
team_makes = sum(isShotMade),
team_avg_distance = mean(distanceShot)) %>%
mutate_at(vars(team_accuracy, team_avg_distance), funs(round(.,4))) %>%
mutate( team_accuracy = team_accuracy * 100,
zone = "Above the Break 3")
lc3_t <- shotData_team %>%
filter( zoneBasic == "Left Corner 3") %>%
summarise( team_accuracy = mean(isShotMade),
team_shots = sum(isShotAttempted),
team_makes = sum(isShotMade),
team_avg_distance = mean(distanceShot))%>%
mutate_at(vars(team_accuracy, team_avg_distance), funs(round(.,4))) %>%
mutate( team_accuracy = team_accuracy * 100,
zone = "Left Corner 3")
mr_t <- shotData_team %>%
filter( zoneBasic == "Mid-Range") %>%
summarise( team_accuracy = mean(isShotMade),
team_shots = sum(isShotAttempted),
team_makes = sum(isShotMade),
team_avg_distance = mean(distanceShot))%>%
mutate_at(vars(team_accuracy, team_avg_distance), funs(round(.,4))) %>%
mutate( team_accuracy = team_accuracy * 100,
zone = "Mid-Range")
rc3_t <- shotData_team %>%
filter( zoneBasic == "Right Corner 3") %>%
summarise( team_accuracy = mean(isShotMade),
team_shots = sum(isShotAttempted),
team_makes = sum(isShotMade),
team_avg_distance = mean(distanceShot))%>%
mutate_at(vars(team_accuracy, team_avg_distance), funs(round(.,4))) %>%
mutate( team_accuracy = team_accuracy * 100,
zone = "Right Corner 3")
ip_t <- shotData_team %>%
filter( zoneBasic == "In The Paint (Non-RA)") %>%
summarise( team_accuracy = mean(isShotMade),
team_shots = sum(isShotAttempted),
team_makes = sum(isShotMade),
team_avg_distance = mean(distanceShot))%>%
mutate_at(vars(team_accuracy, team_avg_distance), funs(round(.,4))) %>%
mutate( team_accuracy = team_accuracy * 100,
zone = "In the Paint (non RA)")
ra_t <- shotData_team %>%
filter( zoneBasic == "Restricted Area") %>%
summarise( team_accuracy = mean(isShotMade),
team_shots = sum(isShotAttempted),
team_makes = sum(isShotMade),
team_avg_distance = mean(distanceShot))%>%
mutate_at(vars(team_accuracy, team_avg_distance), funs(round(.,4))) %>%
mutate(zone = "Restricted Area",
team_accuracy = team_accuracy * 100,)
st_team <- bind_rows(ra_t, ip_t, mr_t, abb3_t, lc3_t, rc3_t) %>%
select(zone, team_makes, team_shots, team_accuracy, team_avg_distance) %>%
rename( 'team_accuracy %' = team_accuracy,
team_attempts = team_shots) %>%
mutate( 'team_pts/att' =
case_when(
zone == "Restricted Area" ~ (team_makes * 2)/team_attempts,
zone == "In the Paint (non RA)" ~ (team_makes * 2)/team_attempts,
zone == "Mid-Range" ~ (team_makes * 2)/team_attempts,
TRUE ~ (team_makes * 3)/team_attempts
)) %>%
mutate_at(vars('team_pts/att'), funs(round(.,4))) %>%
select( zone, 'team_accuracy %', 'team_pts/att')
st %>%
reactable() %>%
add_title("Attempts, Makes, & Accuracy by Zone")Attempts, Makes, & Accuracy by Zone
right_join(st, st_team) %>%
select( zone, 'accuracy %', 'team_accuracy %', 'pts/att', 'team_pts/att') %>%
reactable(sortable = TRUE) %>%
add_title("Player vs Team")Player vs Team
Left vs Right Tables
lip <- shotData %>%
filter( zoneBasic == "In The Paint (Non-RA)",
x > 0) %>%
summarise( accuracy = mean(isShotMade),
shots = sum(isShotAttempted),
makes = sum(isShotMade),
avg_distance = mean(distanceShot))%>%
mutate_at(vars(accuracy, avg_distance), funs(round(.,4))) %>%
mutate( accuracy = accuracy * 100,
zone = "In the Paint (non RA)",
side = "Left")
rip <- shotData %>%
filter( zoneBasic == "In The Paint (Non-RA)",
x < 0) %>%
summarise( accuracy = mean(isShotMade),
shots = sum(isShotAttempted),
makes = sum(isShotMade),
avg_distance = mean(distanceShot))%>%
mutate_at(vars(accuracy, avg_distance), funs(round(.,4))) %>%
mutate( accuracy = accuracy * 100,
zone = "In the Paint (non RA)",
side = "Right")
bind_rows(lip, rip) %>%
select(side,zone, makes, shots, accuracy, avg_distance) %>%
reactable( sortable = TRUE) %>%
add_title("Left vs Right: In the Paint (non-RA)")Left vs Right: In the Paint (non-RA)
Team Shot Table
lmr <- shotData %>%
filter( zoneBasic == "Mid-Range",
x > 0) %>%
summarise( accuracy = mean(isShotMade),
shots = sum(isShotAttempted),
makes = sum(isShotMade),
avg_distance = mean(distanceShot))%>%
mutate_at(vars(accuracy, avg_distance), funs(round(.,4))) %>%
mutate( accuracy = accuracy * 100,
zone = "Mid-Range",
side = "Left")
rmr <- shotData %>%
filter( zoneBasic == "Mid-Range",
x < 0) %>%
summarise( accuracy = mean(isShotMade),
shots = sum(isShotAttempted),
makes = sum(isShotMade),
avg_distance = mean(distanceShot))%>%
mutate_at(vars(accuracy, avg_distance), funs(round(.,4))) %>%
mutate( accuracy = accuracy * 100,
zone = "Mid-Range",
side = "Right")
bind_rows(lmr, rmr) %>%
select(side,zone, makes, shots, accuracy, avg_distance) %>%
reactable( sortable = TRUE) %>%
add_title("Left vs Right: Mid-Range")Left vs Right: Mid-Range
st_team_tbl <- bind_rows(ra_t, ip_t, mr_t, abb3_t, lc3_t, rc3_t) %>%
select(zone, team_makes, team_shots, team_accuracy, team_avg_distance) %>%
rename( 'team_accuracy %' = team_accuracy,
team_attempts = team_shots) %>%
mutate( 'pts/att' =
case_when(
zone == "Restricted Area" ~ (team_makes * 2)/team_attempts,
zone == "In the Paint (non RA)" ~ (team_makes * 2)/team_attempts,
zone == "Mid-Range" ~ (team_makes * 2)/team_attempts,
TRUE ~ (team_makes * 3)/team_attempts
)) %>%
mutate_at(vars('pts/att'), funs(round(.,4)))
st_team_tbl %>%
reactable(sortable = TRUE) %>%
add_title("Nuggets 2020-2021 Season Shot Summary")Nuggets 2020-2021 Season Shot Summary
- Quick Summary Template:
- Favorite zone = highest number of shot attempts
- Best zone = highest pts/att
- Worst zone = lowest pts/att
All stats are from the 2020-2021 regular season.
All tables are sortable by clicking on column header.
Data restricts ability to filter by assisted vs unassisted without making unsupported assumptions.