Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
R function to auto generate heat map shot charts, need help completing court drawing then to complete
#' NBA Player Shot Chart
#'
#' @param player name the player, must be exact
#' @param author, year_end_season: numeric end of season
#'
#' @return
#' @export
#'
#' @examples boggie_bog <- plot_player_shot_chart(player = "Bojan Bogdanovic",
#year_season_end = 2015, exclude_backcourt = T
#author = "Alex Bresler")
options(warn = -1)
packages <- #need all of these installed including some from github
c(
'dplyr',
'magrittr',
'RCurl',
'jsonlite',
'ggExtra',
'viridis',
#devtools::install_github(hrbrmstr/viridis)
'tidyr',
'ggthemes',
'stringr',
'formattable',
#devtools::install_github(renkun-ken/formattable)
"png",
"grid",
'gridExtra',
'rbokeh',
'jpeg',
'hexbin',
'ggplot2',
'stringr',
'tidyr'
)
options(warn = -1)
lapply(packages, library, character.only = T)
plot_player_shot_chart <- function(player,
year_season_end = 2015,
exclude_backcourt = T,
author = "Alex Bresler") {
player %<>%
str_to_title()
year_season_start <-
year_season_end - 1
id.season <-
year_season_start %>%
paste(year_season_end %>% substr(start = 3, stop = 4),
sep = "-")
players.url <-
"http://stats.nba.com/stats/commonallplayers?IsOnlyCurrentSeason=0&LeagueID=00&Season=2015-16"
players.data <-
players.url %>%
fromJSON(simplifyDataFrame = T)
players <-
players.data$resultSets$rowSet %>%
data.frame %>%
tbl_df
names(players) <-
players.data$resultSets$headers %>%
unlist %>%
tolower
players %<>%
separate(
display_last_comma_first,
sep = '\\,',
into = c('name.last', 'name.first')
) %>%
rename(id.player = person_id) %>%
mutate(
name.first = name.first %>% gsub("[^A-Z a-z]", '', .),
name.player = ifelse(
name.first %>% is.na,
name.last,
paste(name.first %>% str_trim, name.last %>% str_trim)
),
id.player = id.player %>% as.numeric,
is.active_player = rosterstatus %>% str_detect("0")
) %>%
select(name.player, everything())
if (players %>% dplyr::filter(name.player == player) %>% .$id.player %>% length == 0) {
stop.message <-
"I'm sorry " %>%
paste0(player,
' is not a valid player, try capitalizing or checking spelling')
stop(stop.message,call. = FALSE)
} else {
id.player <-
players %>%
dplyr::filter(name.player == player) %>%
.$id.player
base_url <-
'http://stats.nba.com/stats/shotchartdetail?CFID=33&CFPARAMS='
stem.2 <-
'&ContextFilter=&ContextMeasure=FGA&DateFrom=&DateTo=&GameID=&GameSegment=&LastNGames=0&LeagueID=00&Location=&MeasureType=Base&Month=0&OpponentTeamID=0&Outcome=&PaceAdjust=N&PerMode=PerGame&Period=0&PlayerID='
stem.3 <-
"&PlusMinus=N&Position=&Rank=N&RookieYear=&Season=" %>%
paste0(
id.season,
"&SeasonSegment=&SeasonType=Regular+Season&TeamID=0&VsConference=&VsDivision=&mode=Advanced&showDetails=0&showShots=1&showZones=0"
)
shot_data_url <-
base_url %>%
paste0(id.season, stem.2, id.player, stem.3)
data <-
shot_data_url %>%
fromJSON(simplifyDataFrame = T)
data.shots <-
data$resultSets$rowSet %>%
.[1] %>%
data.frame %>%
tbl_df
names(data.shots) <-
data$resultSets$headers %>%
.[1] %>%
unlist %>%
str_to_lower()
data.shots %<>%
mutate_each(funs(as.numeric), matches("loc")) %>%
mutate_each(funs(as.numeric), matches("remaining")) %>%
mutate_each(funs(as.numeric), matches("id")) %>%
mutate_each(funs(as.numeric), matches("distance")) %>%
mutate(
period = period %>% as.numeric,
shot_attempted_flag = "1" %>% grepl(shot_attempted_flag),
shot_made_flag = "1" %>% grepl(shot_made_flag)
)
url.player.photo <-
"http://stats.nba.com/media/players/230x185/" %>%
paste0(id.player, '.png')
con <-
url.player.photo %>%
url(open = 'rb')
rawpng <-
con %>%
readBin(what = 'raw', n = 50000)
close(con)
png1 <-
rawpng %>%
readPNG
g <-
png1 %>%
rasterGrob(
interpolate = TRUE,
width = unit(1, "npc"),
height = unit(1, "npc")
)
courtImg.URL <-
"http://lookingforamerica.us/wp-content/uploads/2015/03/Nba-Basketball-Court-Dimensions.jpg"
court <-
courtImg.URL %>%
getURLContent %>%
readJPEG %>%
rasterGrob(width = unit(1, "npc"), height = unit(1, "npc"))
summary_shots <-
data.shots %>%
group_by(shot_made_flag) %>%
summarise(shots = n())
title <-
player %>%
paste0(
" Shot Chart\n",
id.season,
' Season',
'\n',
summary_shots$shots[2],
' Shots Made and ',
summary_shots$shots[1],
' Shots Missed, FG% of ',
summary_shots$shots[2] / data.shots %>% nrow * 100 %>% digits(2),
'%'
)
if (exclude_backcourt == T) {
data.shots %<>%
dplyr::filter(!shot_zone_basic == 'Backcourt')
}
accuracy_data <-
data.shots %>%
group_by(shot_zone_basic) %>%
mutate(shot_value = ifelse(shot_made_flag == TRUE, 1, 0)) %>%
summarise(
attempts = n(),
made = sum(shot_value),
loc_x = loc_x %>% mean,
loc_y = loc_y %>% mean,
accuracy = made / attempts,
accuracy_label = percent(accuracy)
)
if ("Left Corner 3" %in% accuracy_data$shot_zone_basic == F) {
accuracy_data %<>%
bind_rows(data_frame(
shot_zone_basic = "Left Corner 3",
attempts = 0,
accuracy_label = NA
))
}
if ("Right Corner 3" %in% accuracy_data$shot_zone_basic == F) {
accuracy_data %<>%
bind_rows(data_frame(
shot_zone_basic = "Right Corner 3",
attempts = 0,
accuracy_label = NA
))
}
if ("Above the Break 3" %in% accuracy_data$shot_zone_basic == F) {
accuracy_data %<>%
bind_rows(
data_frame(
shot_zone_basic = "Above the Break 3",
attempts = 0,
accuracy_label = NA
)
)
}
if ("Restricted Area" %in% accuracy_data$shot_zone_basic == F) {
accuracy_data %<>%
bind_rows(
data_frame(
shot_zone_basic = "Restricted Area",
attempts = 0,
accuracy_label = NA
)
)
}
if ("Mid-Range" %in% accuracy_data$shot_zone_basic == F) {
accuracy_data %<>%
bind_rows(data_frame(
shot_zone_basic = "Mid-Range",
attempts = 0,
accuracy_label = NA
))
}
if ("In The Paint (Non-RA)" %in% accuracy_data$shot_zone_basic == F) {
accuracy_data %<>%
bind_rows(
data_frame(
shot_zone_basic = "In The Paint (Non-RA)",
attempts = 0,
accuracy_label = NA
)
)
}
accuracy_data %<>%
mutate(accuracy_label = accuracy_label %>% percent())
cols <-
c("FALSE" = "red",
"TRUE" = "black")
p <-
data.shots %>%
ggplot(aes(loc_x, loc_y)) +
annotation_custom(court, -250, 250, -50, 420) +
stat_density2d(
geom = "tile",
aes(fill = ..density.. ^ 0.25),
alpha = .60,
contour = F
) +
scale_fill_viridis(guide_legend(
label = T,
title = "Shot Density\n % FG Attempts",
override.aes = list(alpha = .25, fill = 'white')
)) +
geom_point(
size = 1,
aes(colour = shot_made_flag, scatter = 'jitter'),
alpha = .75
) +
scale_color_manual(
values = cols,
name = '',
labels = c("Shot Missed", "Shot Made")
) +
theme_bw() +
xlim(-250, 250) +
ylim(-50, 420) +
theme(
panel.background = element_rect("black"),
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor.y = element_blank(),
rect = element_blank(),
legend.key = element_blank(),
legend.background = element_rect(fill = "white", colour = "white"),
legend.position = "blank",
axis.text = element_blank(),
axis.ticks.x = element_blank(),
axis.ticks.y = element_blank(),
plot.title = element_text(
size = 12,
colour = "white",
face = "bold"
),
plot.margin = unit(c(.15, .75, .15, .75), "cm")
) +
labs(y = NULL, x = NULL) +
annotation_custom(
g,
xmin = 130,
xmax = 230,
ymin = 300,
ymax = 400
) +
ggplot2::annotate(
"text",
x = -200,
y = 325,
label = paste0("Authored by\n", author),
colour = "black"
) +
ggplot2::annotate(
"text",
x = 0,
y = 325,
label = title,
size = 5,
colour = "black"
) +
annotate(
"text",
x = 0,
y = 235,
label = paste(
"Above the Break 3",
#center 3
accuracy_data %>%
dplyr::filter(shot_zone_basic == "Above the Break 3") %>%
.$accuracy_label,
sep = '\n'
),
size = 4.5,
colour = "white"
) +
annotate(
"text",
x = 0,
y = 90,
label = paste(
"In The Paint (Non-RA)",
#paint
accuracy_data %>%
dplyr::filter(shot_zone_basic == "In The Paint (Non-RA)") %>%
.$accuracy_label,
sep = '\n'
),
size = 4.5,
colour = "white"
) +
annotate(
"text",
x = -208,
y = 15,
angle = 90,
label = paste(
"Left Corner 3",
#left3
accuracy_data %>%
dplyr::filter(shot_zone_basic == "Left Corner 3") %>%
.$accuracy_label,
sep = '\n'
),
size = 4.5,
colour = "white"
) +
annotate(
"text",
x = 0,
y = 160,
label = paste(
"Mid-Range",
#mid
accuracy_data %>%
dplyr::filter(shot_zone_basic == "Mid-Range") %>%
.$accuracy_label,
sep = '\n'
),
size = 4.5,
colour = "white"
) +
annotate(
"text",
x = 0,
y = -25,
label = paste(
"Restricted Area",
#restricted
accuracy_data %>%
dplyr::filter(shot_zone_basic == "Restricted Area") %>%
.$accuracy_label,
sep = '\n'
),
size = 4.5,
colour = "white"
) +
annotate(
"text",
x = 208,
y = 15,
angle = 90,
label = paste(
"Right Corner 3",
#right3
accuracy_data %>%
dplyr::filter(shot_zone_basic == "Right Corner 3") %>%
.$accuracy_label,
sep = '\n'
),
size = 4.5,
colour = "white"
)
p <-
ggMarginal(p,
type = c("density"),
colour = 'black',
size = 10)
p
}
}
@jalapic
Copy link

jalapic commented Aug 1, 2015

I'm getting this error when I try and run:

Error: Values not split into 2 pieces at 1591, 1616, 2345, 4044, 4050

@jalapic
Copy link

jalapic commented Aug 1, 2015

These refer to getting player names: Nene, The Body Hoffman Bear ???, Hound Dog Ted McCain, Yao Ming, Yi Jianlian..............

@abresler
Copy link
Author

abresler commented Aug 1, 2015

Needs to have the data for that year have to look at when it starts to restrict, may also have asci formatting things for some names, I'll get deeper

@abresler
Copy link
Author

abresler commented Sep 10, 2015

Need to work on getting the court geoms will also fix the name issued tonight too

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment