Hugging Face's logo

Spaces:
WVUBaseball
/
App
Sleeping

App Files Community
App / R /visualization_functions.R
cdcavin's picture
cdcavin
Upload visualization_functions.R
5ddccf1 verified
Raw History Blame Contribute Delete
232 kB
FALL_POOL_MAP <- c("Fall 2026" = "Fall 2025")
pool_season <- function(season) {
if (is.null(season) || length(season) != 1L || is.na(season)) return(season)
if (season %in% names(FALL_POOL_MAP)) unname(FALL_POOL_MAP[[season]]) else season
}
pool_pbp <- function(df, season) {
ps <- pool_season(season)
fallback <- if (!is.null(season)) dplyr::filter(df, Season == season) else df
if (identical(ps, season) || !exists("tm_pbp_ds", envir = globalenv())) return(fallback)
out <- tryCatch(
dplyr::collect(dplyr::filter(get("tm_pbp_ds", envir = globalenv()), Season == ps)),
error = function(e) NULL
)
if (is.null(out) || nrow(out) == 0) fallback else out
}
blank_percentile_plot <- function(title = NULL) {
p <- ggplot() +
theme_void() +
theme(
plot.background = element_rect(fill = "white", color = NA),
panel.background = element_rect(fill = "white", color = NA)
)
if (!is.null(title) && nzchar(title)) {
p <- p +
ggtitle(title) +
theme(plot.title = element_text(hjust = 0.5, face = "bold"))
}
p
}
safe_density_peak <- function(x) {
x <- suppressWarnings(as.numeric(x))
x <- x[is.finite(x)]
if (length(x) < 2 || dplyr::n_distinct(x) < 2) {
return(NA_real_)
}
max(stats::density(x, na.rm = TRUE)$y)
}
filter_out_scrimmage_dates <- function(data) {
scrimmage_dates <- get0("scrimmage_dates", ifnotfound = character())
if (is.null(data) || nrow(data) == 0 || length(scrimmage_dates) == 0 || !"Date" %in% names(data)) {
return(data)
}
data %>%
dplyr::filter(!(as.character(Date) %in% as.character(scrimmage_dates)))
}
filter_rows_by_selection <- function(data, name_col, selected_name, selected_ids = NULL, id_col = NULL, team_cols = character()) {
if (nrow(data) == 0) {
return(data)
}
if (!is.null(selected_ids) && length(selected_ids) > 0 && !is.null(id_col) && id_col %in% names(data)) {
by_id <- data %>%
dplyr::filter(as.character(.data[[id_col]]) %in% as.character(selected_ids))
if (nrow(by_id) > 0) {
return(by_id)
}
}
if (!(name_col %in% names(data))) {
return(data[0, , drop = FALSE])
}
by_name <- data %>%
dplyr::filter(.data[[name_col]] == selected_name)
available_team_cols <- intersect(team_cols, names(by_name))
team_aliases <- get0("wvu_team_aliases", ifnotfound = character())
if (length(team_aliases) > 0 && length(available_team_cols) > 0 && nrow(by_name) > 0) {
keep <- Reduce(`|`, lapply(available_team_cols, function(col) {
as.character(by_name[[col]]) %in% team_aliases
}))
by_team <- by_name[keep %in% TRUE, , drop = FALSE]
if (nrow(by_team) > 0) {
return(by_team)
}
}
by_name
}
hitter_percentiles <- function(df, batter, season = NULL, batter_ids = NULL, hitter_stats_df = hitter_stats) {
# Use pre-computed stats from hitter_stats instead of computing from df
df <- filter_out_scrimmage_dates(df)
batter_data <- filter_rows_by_selection(df, "Batter", batter, batter_ids, id_col = "BatterId", team_cols = c("BatterTeam"))
if (!is.null(season)) {
batter_data <- batter_data %>% filter(Season == season)
}
batter_row <- filter_rows_by_selection(
hitter_stats_df,
"Name",
batter,
batter_ids,
id_col = "Id",
team_cols = c("Team", "team_name")
)
if (!is.null(season)) {
batter_row <- batter_row %>% filter(Season == season)
}
batter_row <- batter_row %>%
slice(1) # Take first row if multiple seasons
season_summary_df <- hitter_stats_df %>%
{ if (!is.null(season)) dplyr::filter(., Season == pool_season(season)) else . } %>%
dplyr::filter(PA >= 50) %>%
dplyr::transmute(
xwOBA = xwOBA,
xBA = xBA,
xSLG = xSLG,
`Max EV` = max_ev,
`Barrel%` = barrel_pct,
`Hard-Hit%` = hard_hit_pct,
`SwSpot%` = sweet_spot_pct,
`Pull Air%` = pull_air_pct,
`HR/FB%` = hr_fb_pct,
`Chase%` = chase_pct,
Decisions = decisions,
`Whiff%` = whiff_pct,
`Z-Con%` = z_contact_pct,
`K%` = 100 * SO / PA,
`BB%` = 100 * BB / PA
)
if (nrow(season_summary_df) == 0) {
season_domain_data <- pool_pbp(df, season) %>%
dplyr::filter(!is.na(Batter))
season_summary_df <- season_domain_data %>%
dplyr::group_by(Batter) %>%
dplyr::summarise(
xwOBA = mean(xwOBA, na.rm = TRUE),
xBA = mean(xba, na.rm = TRUE),
xSLG = mean(xslg, na.rm = TRUE),
`Max EV` = max(ExitSpeed, na.rm = TRUE),
`Barrel%` = 100 * mean(is_barrel, na.rm = TRUE),
`Hard-Hit%` = 100 * mean(is_hard_hit, na.rm = TRUE),
`SwSpot%` = 100 * sum(PitchCall == "InPlay" & Angle >= 8 & Angle <= 32, na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Pull Air%` = 100 * sum(
if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) &
AutoHitType %in% c("FlyBall", "LineDrive", "Popup") &
PitchCall == "InPlay",
na.rm = TRUE
) / sum(PitchCall == "InPlay", na.rm = TRUE),
`HR/FB%` = 100 * sum(AutoHitType == "FlyBall" & PlayResult == "Homerun" & PitchCall == "InPlay", na.rm = TRUE) /
sum(AutoHitType == "FlyBall" & PitchCall == "InPlay", na.rm = TRUE),
`Chase%` = 100 * mean(chase, na.rm = TRUE),
Decisions = 100 * mean(sd_rv_added, na.rm = TRUE),
`Whiff%` = 100 * mean(is_whiff, na.rm = TRUE),
`Z-Con%` = 100 * (1 - mean(in_zone_whiff, na.rm = TRUE)),
`K%` = 100 * mean(is_k, na.rm = TRUE),
`BB%` = 100 * mean(is_walk, na.rm = TRUE),
.groups = "drop"
) %>%
dplyr::select(-Batter) %>%
dplyr::mutate(dplyr::across(dplyr::everything(), ~ ifelse(is.nan(.x), NA_real_, .x)))
}
if (nrow(season_summary_df) == 0) {
return(blank_percentile_plot("Hitting"))
}
if (nrow(batter_row) == 0 && nrow(batter_data) == 0) {
return(blank_percentile_plot("Hitting"))
}
if (nrow(batter_row) == 0) {
# Fallback to computing from df if not found in hitter_stats
batter_split <- batter_data %>%
summarise(
xwOBA = sprintf("%.3f", mean(xwOBA, na.rm = TRUE)),
xBA = sprintf("%.3f", mean(xba, na.rm = TRUE)),
xSLG = sprintf("%.3f", mean(xslg, na.rm = TRUE)),
`Max EV` = sprintf("%.1f", max(ExitSpeed, na.rm = TRUE)),
`Barrel%` = sprintf("%.1f", 100 * mean(is_barrel, na.rm = TRUE)),
`Hard-Hit%` = sprintf("%.1f", 100 * mean(is_hard_hit, na.rm = TRUE)),
`SwSpot%` = sprintf("%.1f", 100 * sum(PitchCall == "InPlay" & Angle >= 8 & Angle <= 32, na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE)),
`Pull Air%` = sprintf("%.1f", 100 * sum(if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) &
AutoHitType %in% c("FlyBall", "LineDrive", "Popup") &
PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE)),
`HR/FB%` = sprintf("%.1f", 100 * sum(AutoHitType == "FlyBall" & PlayResult == "Homerun" & PitchCall == "InPlay", na.rm = TRUE) /
sum(AutoHitType == "FlyBall" & PitchCall == "InPlay", na.rm = TRUE)),
`Chase%` = sprintf("%.1f", 100 * mean(chase, na.rm = TRUE)),
Decisions = sprintf("%.2f", 100 * mean(sd_rv_added, na.rm = TRUE)),
`Whiff%` = sprintf("%.1f", 100 * mean(is_whiff, na.rm = TRUE)),
`Z-Con%` = sprintf("%.1f", 100 * (1 - mean(in_zone_whiff, na.rm = TRUE))),
`K%` = sprintf("%.1f", 100 * mean(is_k, na.rm = TRUE)),
`BB%` = sprintf("%.1f", 100 * mean(is_walk, na.rm = TRUE)),
.groups = "drop"
) %>%
mutate(across(everything(), as.numeric))
} else {
# Use pre-computed stats from hitter_stats (already in percentage form)
batter_split <- tibble(
xwOBA = batter_row$xwOBA,
xBA = batter_row$xBA,
xSLG = batter_row$xSLG,
`Max EV` = batter_row$max_ev,
`Barrel%` = batter_row$barrel_pct,
`Hard-Hit%` = batter_row$hard_hit_pct,
`SwSpot%` = batter_row$sweet_spot_pct,
`Pull Air%` = batter_row$pull_air_pct,
`HR/FB%` = batter_row$hr_fb_pct,
`Chase%` = batter_row$chase_pct,
Decisions = batter_row$decisions,
`Whiff%` = batter_row$whiff_pct,
`Z-Con%` = batter_row$z_contact_pct,
`K%` = 100 * batter_row$SO / batter_row$PA,
`BB%` = 100 * batter_row$BB / batter_row$PA
)
}
batter_split <- batter_split %>%
mutate(across(everything(), ~ ifelse(is.nan(.x), NA_real_, .x)))
if (all(is.na(unlist(batter_split)))) {
return(blank_percentile_plot("Hitting"))
}
percentile_df <- batter_split %>%
pivot_longer(everything(), names_to = "Metric", values_to = "Value") %>%
mutate(
Percentile = purrr::map2_dbl(Metric, Value, function(m, v) {
vals <- season_summary_df[[m]]
if (is.null(vals) || all(is.na(vals))) return(NA_real_)
if (m %in% c("Chase%", "Whiff%", "K%")) {
mean(vals >= v, na.rm = TRUE) * 100
} else {
mean(vals <= v, na.rm = TRUE) * 100
}
}),
Fill = gradient_n_pal(c("#315aa1", "#b4cfd0", "#d72029"))(Percentile / 100)
) %>%
mutate(
Percentile = ifelse(is.nan(Percentile), NA_real_, Percentile),
Value = ifelse(is.nan(Value), NA_real_, Value)
) %>%
filter(!is.na(Value))
if (nrow(percentile_df) == 0) {
return(blank_percentile_plot("Hitting"))
}
percentile_points <- percentile_df %>% filter(!is.na(Percentile))
percentile_df <- percentile_df %>%
mutate(
Value = case_when(
Metric %in% c("xwOBA", "xBA", "xSLG") ~ sprintf("%.3f", Value),
Metric == "Decisions" ~ sprintf("%.2f", Value),
TRUE ~ sprintf("%.1f", Value)
)
)
ggplot(percentile_df, aes(y = factor(Metric, levels = rev(Metric)))) +
geom_tile(aes(x = 50, width = 100), fill = "#c7dcdc", alpha = 0.3, height = 0.25) +
geom_tile(aes(x = Percentile / 2, width = Percentile, fill = Fill), height = 0.7) +
geom_text(aes(x = -3, label = Metric), hjust = 1, size = 5.25) +
geom_text(aes(x = 103, label = Value), hjust = 0, size = 5.25) +
geom_point(data = percentile_points, aes(x = Percentile), color = "white", size = 10, shape = 21, stroke = 2.25, fill = percentile_points$Fill) +
geom_text(data = percentile_points, aes(x = Percentile, label = round(Percentile)), size = 4, color = "white", fontface = "bold") +
geom_segment(aes(x = -2, xend = -16,
y = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3,
yend = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3),
linetype = "longdash", color = "#399098", size = 1) +
geom_segment(aes(x = 102, xend = 113,
y = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3,
yend = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3),
linetype = "longdash", color = "#399098", size = 1) +
scale_x_continuous(limits = c(-16, 113), expand = c(0, 0)) +
scale_fill_identity() +
theme_minimal() +
ggtitle("Hitting") +
theme(plot.title = element_text(hjust = .5, face = "bold"),
panel.background = element_rect(fill = "white"),
axis.text = element_blank(),
axis.title = element_blank(),
panel.grid = element_blank()
)
}
fielding_percentiles <- function(defense, batter, season, batter_ids = NULL) {
defense_season <- defense %>%
{ if (!is.null(season)) dplyr::filter(., Season == season) else . }
defense_pool <- defense %>%
{ if (!is.null(season)) dplyr::filter(., Season == pool_season(season)) else . }
batter_split <- filter_rows_by_selection(
defense_season,
"Name",
batter,
batter_ids,
id_col = "id",
team_cols = c("Team")
) %>%
dplyr::summarise(
OAA = if (all(is.na(OAA))) NA_real_ else sum(OAA, na.rm = TRUE),
FRV = if (all(is.na(frv))) NA_real_ else sum(frv, na.rm = TRUE),
.groups = "drop"
) %>%
dplyr::mutate(
OAA = ifelse(is.infinite(OAA), NA_real_, OAA),
FRV = ifelse(is.infinite(FRV), NA_real_, FRV)
)
if (nrow(batter_split) == 0) {
return(blank_percentile_plot("Fielding"))
}
# Identify what exists for this player-season
has_oaa <- nrow(batter_split) > 0 && any(!is.na(batter_split$OAA))
has_frv <- nrow(batter_split) > 0 && any(!is.na(batter_split$FRV))
percentile_df <- batter_split %>%
tidyr::pivot_longer(dplyr::everything(), names_to = "Metric", values_to = "Value")
if (has_oaa && has_frv) {
percentile_df <- percentile_df
} else if (has_oaa) {
percentile_df <- percentile_df %>% dplyr::filter(.data$Metric == "OAA")
} else if (has_frv) {
percentile_df <- percentile_df %>% dplyr::filter(.data$Metric == "FRV")
} else {
return(blank_percentile_plot("Fielding"))
}
percentile_df <- percentile_df %>%
dplyr::mutate(
Percentile = purrr::map2_dbl(Metric, Value, function(m, v) {
if (is.na(v)) return(NA_real_)
vals <- if (m == "FRV") defense_pool$frv else defense_pool$OAA
if (is.null(vals) || all(is.na(vals))) return(NA_real_)
mean(vals <= v, na.rm = TRUE) * 100
}),
Fill = scales::gradient_n_pal(c("#315aa1", "#b4cfd0", "#d72029"))(Percentile / 100)
)
if (nrow(percentile_df) == 0 || all(is.na(percentile_df$Value))) {
return(blank_percentile_plot("Fielding"))
}
ggplot2::ggplot(percentile_df, ggplot2::aes(y = factor(Metric, levels = rev(unique(Metric))))) +
ggplot2::geom_tile(ggplot2::aes(x = 50, width = 100), fill = "#c7dcdc", alpha = 0.3, height = 0.25) +
ggplot2::geom_tile(ggplot2::aes(x = Percentile / 2, width = Percentile, fill = Fill), height = 0.7, na.rm = TRUE) +
ggplot2::geom_text(ggplot2::aes(x = -3, label = Metric), hjust = 1, size = 5.25) +
ggplot2::geom_text(ggplot2::aes(x = 103, label = Value), hjust = 0, size = 5.25, na.rm = TRUE) +
ggplot2::geom_point(
data = dplyr::filter(percentile_df, !is.na(Percentile)),
ggplot2::aes(x = Percentile),
color = "white", size = 10, shape = 21, stroke = 2.25,
fill = dplyr::filter(percentile_df, !is.na(Percentile))$Fill
) +
ggplot2::geom_text(
data = dplyr::filter(percentile_df, !is.na(Percentile)),
ggplot2::aes(x = Percentile, label = round(Percentile)),
size = 4, color = "white", fontface = "bold"
) +
ggplot2::geom_segment(
ggplot2::aes(x = -2, xend = -16,
y = as.numeric(factor(Metric, levels = rev(unique(Metric)))) - 0.3,
yend = as.numeric(factor(Metric, levels = rev(unique(Metric)))) - 0.3),
linetype = "longdash", color = "#399098", linewidth = 1
) +
ggplot2::geom_segment(
ggplot2::aes(x = 102, xend = 113,
y = as.numeric(factor(Metric, levels = rev(unique(Metric)))) - 0.3,
yend = as.numeric(factor(Metric, levels = rev(unique(Metric)))) - 0.3),
linetype = "longdash", color = "#399098", linewidth = 1
) +
ggplot2::scale_x_continuous(limits = c(-16, 113), expand = c(0, 0)) +
ggplot2::scale_fill_identity() +
ggplot2::theme_minimal() +
ggplot2::ggtitle("Fielding") +
ggplot2::theme(
plot.title = ggplot2::element_text(hjust = .5, face = "bold"),
panel.background = ggplot2::element_rect(fill = "white"),
axis.text = ggplot2::element_blank(),
axis.title = ggplot2::element_blank(),
panel.grid = ggplot2::element_blank()
)
}
value_percentiles <- function(hit_war, batter, season, batter_ids = NULL) {
season_hit_war <- hit_war %>%
filter(Season == season)
if (nrow(season_hit_war) == 0) {
return(blank_percentile_plot("Value"))
}
batter_split <- filter_rows_by_selection(
season_hit_war,
"Batter",
batter,
batter_ids,
id_col = "Id",
team_cols = c("BatterTeam")
) %>%
select(WAR, `WAR/300`, OFF, DEF, BsR) %>%
slice(1) %>%
mutate(
across(everything(), as.numeric),
across(everything(), ~ round(.x, 1))
)
if (nrow(batter_split) == 0) {
return(blank_percentile_plot("Value"))
}
hit_comp_idx <- season_hit_war$PA >= 100
if (!any(hit_comp_idx, na.rm = TRUE)) hit_comp_idx <- season_hit_war$PA >= 50
if (!any(hit_comp_idx, na.rm = TRUE)) hit_comp_idx <- season_hit_war$PA >= 25
if (!any(hit_comp_idx, na.rm = TRUE)) hit_comp_idx <- !is.na(season_hit_war$PA)
percentile_df <- batter_split %>%
pivot_longer(everything(), names_to = "Metric", values_to = "Value") %>%
mutate(
Percentile = purrr::map2_dbl(Metric, Value, function(m, v) {
vals <- season_hit_war[[m]][hit_comp_idx]
if (is.null(vals) || all(is.na(vals))) return(NA_real_)
mean(vals <= v, na.rm = TRUE) * 100
}),
Fill = gradient_n_pal(c("#315aa1", "#b4cfd0", "#d72029"))(Percentile / 100)
)
percentile_df <- percentile_df %>%
filter(!is.na(Value), !is.nan(Value))
if (nrow(percentile_df) == 0) {
return(blank_percentile_plot("Value"))
}
percentile_points <- percentile_df %>% filter(!is.na(Percentile), !is.nan(Percentile))
ggplot(percentile_df, aes(y = factor(Metric, levels = rev(Metric)))) +
geom_tile(aes(x = 50, width = 100), fill = "#c7dcdc", alpha = 0.3, height = 0.25) +
geom_tile(aes(x = Percentile / 2, width = Percentile, fill = Fill), height = 0.7) +
geom_text(aes(x = -3, label = Metric), hjust = 1, size = 5.25) +
geom_text(aes(x = 103, label = Value), hjust = 0, size = 5.25) +
geom_point(data = percentile_points, aes(x = Percentile), color = "white", size = 10, shape = 21, stroke = 2.25, fill = percentile_points$Fill) +
geom_text(data = percentile_points, aes(x = Percentile, label = round(Percentile)), size = 4, color = "white", fontface = "bold") +
geom_segment(aes(x = -2, xend = -16,
y = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3,
yend = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3),
linetype = "longdash", color = "#399098", size = 1) +
geom_segment(aes(x = 102, xend = 113,
y = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3,
yend = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3),
linetype = "longdash", color = "#399098", size = 1) +
scale_x_continuous(limits = c(-16, 113), expand = c(0, 0)) +
scale_fill_identity() +
theme_minimal() +
ggtitle("Value") +
theme(plot.title = element_text(hjust = .5, face = "bold"),
panel.background = element_rect(fill = "white"),
axis.text = element_blank(),
axis.title = element_blank(),
panel.grid = element_blank()
)
}
spray_chart <- function(data, player){
data %>%
filter(Batter == player) %>%
filter(!is.na(Distance) & !is.na(Bearing) & PitchCall == "InPlay",
event_type != "Field Out") %>%
mutate(Bearing2 = Bearing * pi / 180) %>%
mutate(x = Distance * sin(Bearing2),
y = Distance * cos(Bearing2)) %>%
ggplot(aes(x, y, fill = event_type)) +
scale_fill_identity() +
scale_fill_manual(
values = c(
"Single" = "#fe6000",
"Double" = "#785ef0",
"Triple" = "#ffb000",
"Home Run" = "#dc267e"
),
limits = NULL,
breaks = c("Single", "Double", "Triple", "Home Run"),
name = NULL
) +
coord_fixed() +
annotate("segment", x = 0, y = 0, xend = 247.487, yend = 247.487, color = "black") +
annotate("segment", x = 0, y = 0, xend = -247.487, yend = 247.487, color = "black") +
annotate("segment", x = 63.6396, y = 63.6396, xend = 0, yend = 127.279, color = "black") +
annotate("segment", x = -63.6396, y = 63.6396, xend = 0, yend = 127.279, color = "black") +
annotate("curve", x = 89.095, y = 89.095, xend = 0, yend = 160, curvature = 0.36, linewidth = .5, color = "black") +
annotate("curve", x = -89.095, y = 89.095, xend = 0, yend = 160, curvature = -0.36, linewidth = .5, color = "black") +
annotate("curve", x = -247.487, y = 247.487, xend = 247.487, yend = 247.487, curvature = -0.65, linewidth = .5, color = "black") +
geom_point(size = 4, shape = 21, color = "black", stroke = .5) +
theme_void() +
ylim(0, 435) +
theme(legend.position = "right",
legend.title = element_blank())
}
radial <- function(data, batter){
radial_df <- data %>%
filter(Batter == batter, PitchCall == "InPlay", !is.na(ExitSpeed), !is.na(Angle)) %>%
mutate(Angle_rad = Angle * pi / 180,
radial_x = ExitSpeed * cos(Angle_rad),
radial_y = ExitSpeed * sin(Angle_rad)) %>%
select(PitchCall, PlayResult, radial_x, radial_y, event_type)
grid %>%
ggplot() +
geom_tile(aes(x = radial_x, y = radial_y, fill = factor(xwOBA)),
width = 2.5, height = 2.5,
show.legend = FALSE) +
annotate(
"segment",
x = 0,
y = 0,
xend = 125 * cos(45 * pi / 180),
yend = 125 * sin(45 * pi / 180),
color = "white",
linewidth = 0.5
) +
annotate("segment", x = 0, y = 0, xend = 125, yend = 0, color = "white", linewidth = 0.5) +
annotate("point", x = -2.5, y = 0, color = "white", size = 8) +
geom_point(
data = radial_df,
aes(x = radial_x, y = radial_y, fill = event_type),
size = 2.5,
shape = 21,
color = "black",
alpha = .91,
inherit.aes = FALSE
) +
scale_fill_manual(
values = c(
"0" = "#b0d3d6",
"1" = "#3a9098",
"Single" = "#fe6000",
"Double" = "#785ef0",
"Triple" = "#ffb000",
"Home Run" = "#dc267e",
"Field Out" = "#c2c2c2"
),
limits = NULL,
breaks = c("Single", "Double", "Triple", "Home Run", "Field Out"),
name = NULL
) +
coord_fixed() +
annotate("text", x = 125, y = 0, label = "0°", color = "black", size = 2.5, vjust = 0.5, hjust = 0) +
annotate("text", x = 135, y = 0, label = "120 MPH", color = "black", size = 2.5, vjust = 0.5, hjust = 0) +
annotate("text", x = 0, y = 125, label = "90°", color = "black", size = 2.5, vjust = 0.5, hjust = 0) +
annotate("text", x = 0, y = 135, label = "120 MPH", color = "black", size = 2.5, vjust = 0.5, hjust = 0) +
annotate("text", x = 125 * cos(45 * pi / 180), y = 125 * sin(45 * pi / 180), label = "45°", color = "black", size = 2.5, vjust = 0.5, hjust = 0) +
annotate("text", x = 135 * cos(45 * pi / 180), y = 135 * sin(45 * pi / 180), label = "120 MPH", color = "black", size = 2.5, vjust = 0.5, hjust = 0) +
xlim(-5, 155) +
ylim(-135, 135) +
theme_minimal() +
labs(x = NULL, y = NULL) +
theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank(),
legend.position = "none"
)
}
rolling_xwOBA <- function(data, batter) {
required_cols <- c("Date", "Inning", "PitchNo", "PitchCall", "KorBB", "xwOBA", "Batter")
missing_cols <- setdiff(required_cols, names(data))
if (length(missing_cols) > 0) {
return(ggplot() + theme_void())
}
mean_xwOBA_player <- data %>%
filter(Batter == batter) %>%
filter(PitchCall == "InPlay" | KorBB == "Strikeout" |
KorBB == "Walk" | PitchCall == "HitByPitch") %>%
summarise(xwOBA = mean(xwOBA, na.rm = TRUE)) %>%
mutate(xwOBA = round(xwOBA, 3)) %>%
pull(xwOBA)
player_data <- data %>%
filter(Batter == batter) %>%
filter(PitchCall == "InPlay" | KorBB == "Strikeout" |
KorBB == "Walk" | PitchCall == "HitByPitch") %>%
filter(!is.na(xwOBA)) %>%
group_by(Date, Inning, PitchNo) %>%
arrange(Date, Inning, PitchNo) %>%
summarise(xwOBA = mean(xwOBA)) %>%
ungroup() %>%
mutate(abn = row_number()) %>%
mutate(rolling_xwOBA = rollmean(xwOBA, 50, fill = NA, align = "right")) %>%
mutate(deviation = rolling_xwOBA - .375) %>%
drop_na(rolling_xwOBA)
if (nrow(player_data) == 0) {
return(ggplot() + theme_void())
}
ggplot(player_data, aes(x = abn, y = rolling_xwOBA)) +
geom_line(aes(color = deviation), na.rm = TRUE) +
geom_hline(yintercept = .370, linetype = "dashed", color = "black") +
xlab("Plate Appearance Number") + ylab("xwOBA") + ylim(min(player_data$rolling_xwOBA - .1),
max(player_data$rolling_xwOBA + .1)) +
ggtitle("50 PA Rolling xwOBA") +
scale_color_gradient2(low = "#315aa1", mid = "#636363", high = "#d72029", midpoint = 0,
limits = c(-.1, .1), name = " ",
oob = scales::squish) +
theme_minimal() +
theme(
plot.title = element_text(hjust = 0.5),
legend.position = "none",
panel.background = element_rect(fill = "white"),
legend.title = element_blank(),
legend.text = element_blank(),
axis.text = element_text(size = 12),
axis.title = element_text(size = 13)
)
}
rolling_xwOBA_pitcher <- function(df, pitcher) {
mean_xwOBA_player <- df %>%
filter(Pitcher == pitcher) %>%
summarise(xwOBA = mean(xwOBA, na.rm = TRUE)) %>%
mutate(xwOBA = round(xwOBA, 3)) %>%
pull(xwOBA)
player_data <- df %>%
filter(Pitcher == pitcher) %>%
filter(!is.na(xwOBA)) %>%
group_by(Date, Inning, PitchNo) %>%
arrange(Date, Inning, PitchNo) %>%
summarise(xwOBA = mean(xwOBA)) %>%
ungroup() %>%
mutate(abn = row_number()) %>%
mutate(rolling_xwOBA = rollmean(xwOBA, 50, fill = NA, align = "right")) %>%
mutate(deviation = rolling_xwOBA - .370) %>%
drop_na(rolling_xwOBA)
ggplot(player_data, aes(x = abn, y = rolling_xwOBA)) +
geom_line(aes(color = deviation), na.rm = TRUE) +
geom_hline(yintercept = .370, linetype = "dashed", color = "black") +
xlab("Plate Appearance Number") + ylab("xwOBA") + ylim(min(player_data$rolling_xwOBA - .1),
max(player_data$rolling_xwOBA + .1)) +
ggtitle("50 PA Rolling xwOBA") +
scale_color_gradient2(low = "#d72029", mid = "#636363", high = "#315aa1", midpoint = 0,
limits = c(-.1, .1), name = " ",
oob = scales::squish) +
theme_minimal() +
theme(
plot.title = element_text(hjust = 0.5),
legend.position = "none",
panel.background = element_rect(fill = "white"),
legend.title = element_blank(),
legend.text = element_blank(),
axis.text = element_text(size = 12),
axis.title = element_text(size = 13)
)
}
# Traditional batting stats table from hitter_stats
traditional_stats <- function(hitter_stats_df, player, season) {
ranges <- hitter_stats %>%
filter(PA >= 100) %>%
summarise(
BA_lo = quantile(BA, 0.10, na.rm = TRUE),
BA_hi = quantile(BA, 0.90, na.rm = TRUE),
OBP_lo = quantile(OBP, 0.10, na.rm = TRUE),
OBP_hi = quantile(OBP, 0.90, na.rm = TRUE),
SLG_lo = quantile(SLG, 0.10, na.rm = TRUE),
SLG_hi = quantile(SLG, 0.90, na.rm = TRUE),
OPS_lo = quantile(OPS, 0.10, na.rm = TRUE),
OPS_hi = quantile(OPS, 0.90, na.rm = TRUE)
)
hitter_stats_df %>%
filter(Name == player, Season == season) %>%
select(any_of(c("G", "PA", "AB", "R", "H", "2B", "3B", "HR", "RBI",
"SB", "CS", "BB", "SO", "BA", "OBP", "SLG", "OPS"))) %>%
mutate(
BA = sprintf("%.3f", BA),
OBP = sprintf("%.3f", OBP),
SLG = sprintf("%.3f", SLG),
OPS = sprintf("%.3f", OPS)
) %>%
mutate(across(c(BA, OBP, SLG, OPS), readr::parse_number)) %>%
gt() %>%
wvu_gt_theme() %>%
data_color(columns = BA, colors = make_color_fn(ranges$BA_lo, ranges$BA_hi)) %>%
data_color(columns = OBP, colors = make_color_fn(ranges$OBP_lo, ranges$OBP_hi)) %>%
data_color(columns = SLG, colors = make_color_fn(ranges$SLG_lo, ranges$SLG_hi)) %>%
data_color(columns = OPS, colors = make_color_fn(ranges$OPS_lo, ranges$OPS_hi)) %>%
fmt_number(columns = c(BA, OBP, SLG, OPS), decimals = 3) %>%
fmt_missing(columns = everything(), missing_text = "-")
}
# Combined traditional + statcast hitter summary (prefer hitter_stats, fallback to Trackman)
hitter_summary_overall <- function(data, player, season, hitter_stats_df = NULL, batter_ids = NULL) {
data <- filter_rows_by_selection(data, "Batter", player, batter_ids, id_col = "BatterId", team_cols = c("BatterTeam"))
trackman_summary <- data %>%
summarise(
Pitches = n(),
PA = sum(is_plate_appearance, na.rm = TRUE),
BB = sum(is_walk, na.rm = TRUE),
SO = sum(is_k, na.rm = TRUE),
HBP = sum(PitchCall == "HitByPitch", na.rm = TRUE),
SF = sum(PlayResult == "Sacrifice", na.rm = TRUE),
H = sum(is_hit, na.rm = TRUE),
`2B` = sum(PlayResult == "Double", na.rm = TRUE),
`3B` = sum(PlayResult == "Triple", na.rm = TRUE),
HR = sum(PlayResult == "Homerun", na.rm = TRUE),
BBE = sum(PitchCall == "InPlay", na.rm = TRUE),
`Barrel%` = if_else(BBE > 0, 100 * sum(is_barrel, na.rm = TRUE) / BBE, NA_real_),
EV = mean(ExitSpeed[PitchCall == "InPlay"], na.rm = TRUE),
EV90 = if_else(
BBE > 0,
as.numeric(stats::quantile(ExitSpeed[PitchCall == "InPlay"], probs = 0.9, na.rm = TRUE, names = FALSE)),
NA_real_
),
`Max EV` = if_else(BBE > 0, max(ExitSpeed[PitchCall == "InPlay"], na.rm = TRUE), NA_real_),
`SwSpot%` = if_else(BBE > 0, 100 * sum(PitchCall == "InPlay" & Angle >= 8 & Angle <= 32, na.rm = TRUE) / BBE, NA_real_),
xBA = mean(xba, na.rm = TRUE),
xwOBA = mean(xwOBA, na.rm = TRUE),
wOBA = mean(woba, na.rm = TRUE),
`Hard-Hit%` = 100 * mean(is_hard_hit, na.rm = TRUE),
`Chase%` = 100 * mean(chase, na.rm = TRUE),
`Whiff%` = 100 * mean(is_whiff, na.rm = TRUE),
`Z-Con%` = 100 * (1 - mean(in_zone_whiff, na.rm = TRUE)),
`K%` = 100 * mean(is_k, na.rm = TRUE),
`BB%` = 100 * mean(is_walk, na.rm = TRUE)
) %>%
mutate(
AB = pmax(PA - BB - HBP - SF, 0),
`1B` = pmax(H - `2B` - `3B` - HR, 0),
TB = `1B` + 2 * `2B` + 3 * `3B` + 4 * HR,
BA = if_else(AB > 0, H / AB, NA_real_),
OBP = if_else((AB + BB + HBP + SF) > 0, (H + BB + HBP) / (AB + BB + HBP + SF), NA_real_),
SLG = if_else(AB > 0, TB / AB, NA_real_),
OPS = OBP + SLG
) %>%
select(-`1B`, -HBP, -SF)
stats_row <- tibble()
if (!is.null(hitter_stats_df)) {
stats_row <- filter_rows_by_selection(
hitter_stats_df,
"Name",
player,
batter_ids,
id_col = "Id",
team_cols = c("Team", "team_name")
) %>%
filter(Season == season) %>%
slice_head(n = 1)
}
hget1 <- function(cols) {
if (!nrow(stats_row)) return(NA_real_)
for (col in cols) {
if (col %in% names(stats_row) && length(stats_row[[col]]) > 0) {
v <- suppressWarnings(as.numeric(stats_row[[col]][[1]]))
if (is.finite(v)) return(v)
}
}
NA_real_
}
stats_g <- hget1(c("G", "GP"))
stats_pa <- hget1(c("PA"))
stats_ab <- hget1(c("AB"))
stats_r <- hget1(c("R"))
stats_h <- hget1(c("H"))
stats_2b <- hget1(c("2B", "X2B"))
stats_3b <- hget1(c("3B", "X3B"))
stats_hr <- hget1(c("HR"))
stats_rbi <- hget1(c("RBI"))
stats_sb <- hget1(c("SB"))
stats_cs <- hget1(c("CS"))
stats_bb <- hget1(c("BB"))
stats_so <- hget1(c("SO", "K"))
stats_ba <- hget1(c("BA"))
stats_obp <- hget1(c("OBP"))
stats_slg <- hget1(c("SLG"))
stats_ev90 <- hget1(c("ev90", "EV90"))
stats_max_ev <- hget1(c("max_ev", "Max EV"))
stats_barrel_pct <- hget1(c("barrel_pct", "Barrel%", "barrel_rate"))
stats_hard_hit_pct <- hget1(c("hard_hit_pct", "Hard-Hit%", "hard_hit_rate"))
stats_sweet_spot_pct <- hget1(c("sweet_spot_pct", "SwSpot%", "sweet_spot_rate"))
stats_chase_pct <- hget1(c("chase_pct", "Chase%", "chase_rate"))
stats_whiff_pct <- hget1(c("whiff_pct", "Whiff%", "whiff_rate"))
stats_z_contact_pct <- hget1(c("z_contact_pct", "Z-Con%", "z_contact_rate"))
stats_ops <- NA_real_
if (nrow(stats_row)) {
if ("OPS" %in% names(stats_row) && length(stats_row$OPS) > 0) {
stats_ops <- suppressWarnings(as.numeric(stats_row$OPS[[1]]))
}
if (!is.finite(stats_ops) && all(c("OBP", "SLG") %in% names(stats_row))) {
stats_ops <- suppressWarnings(as.numeric(stats_row$OBP[[1]])) +
suppressWarnings(as.numeric(stats_row$SLG[[1]]))
}
}
hitter_summary <- trackman_summary %>%
mutate(
G = if (is.finite(stats_g)) stats_g else NA_real_,
PA = if (is.finite(stats_pa)) stats_pa else PA,
AB = if (is.finite(stats_ab)) stats_ab else AB,
R = if (nrow(stats_row) && is.finite(stats_r)) stats_r else NA_real_,
H = if (is.finite(stats_h)) stats_h else H,
`2B` = if (is.finite(stats_2b)) stats_2b else `2B`,
`3B` = if (is.finite(stats_3b)) stats_3b else `3B`,
HR = if (is.finite(stats_hr)) stats_hr else HR,
RBI = if (nrow(stats_row) && is.finite(stats_rbi)) stats_rbi else NA_real_,
SB = if (nrow(stats_row) && is.finite(stats_sb)) stats_sb else NA_real_,
CS = if (nrow(stats_row) && is.finite(stats_cs)) stats_cs else NA_real_,
BB = if (nrow(stats_row) && is.finite(stats_bb)) stats_bb else BB,
SO = if (nrow(stats_row) && is.finite(stats_so)) stats_so else SO,
BA = if (nrow(stats_row) && is.finite(stats_ba)) stats_ba else BA,
OBP = if (nrow(stats_row) && is.finite(stats_obp)) stats_obp else OBP,
SLG = if (nrow(stats_row) && is.finite(stats_slg)) stats_slg else SLG,
OPS = if (nrow(stats_row) && is.finite(stats_ops)) stats_ops else OPS,
EV90 = if (nrow(stats_row) && is.finite(stats_ev90)) stats_ev90 else EV90,
`Max EV` = if (nrow(stats_row) && is.finite(stats_max_ev)) stats_max_ev else `Max EV`,
`Barrel%` = if (is.finite(stats_barrel_pct)) stats_barrel_pct else `Barrel%`,
`Hard-Hit%` = if (is.finite(stats_hard_hit_pct)) stats_hard_hit_pct else `Hard-Hit%`,
`SwSpot%` = if (is.finite(stats_sweet_spot_pct)) stats_sweet_spot_pct else `SwSpot%`,
`Chase%` = if (is.finite(stats_chase_pct)) stats_chase_pct else `Chase%`,
`Whiff%` = if (is.finite(stats_whiff_pct)) stats_whiff_pct else `Whiff%`,
`Z-Con%` = if (is.finite(stats_z_contact_pct)) stats_z_contact_pct else `Z-Con%`
) %>%
select(
G, PA, AB, R, H, HR, RBI, SB, CS, BB, SO,
BA, OBP, SLG, OPS, wOBA, `Barrel%`, `Hard-Hit%`, `SwSpot%`,
`Chase%`, `Whiff%`, `Z-Con%`, EV90, `Max EV`, BBE
) %>%
mutate(across(everything(), ~as.numeric(.)))
hitter_summary %>%
gt() %>%
wvu_gt_theme() %>%
data_color(columns = BA, colors = make_color_fn(
quantile(summary_df$BA, 0.1, na.rm = TRUE),
quantile(summary_df$BA, 0.9, na.rm = TRUE))) %>%
data_color(columns = OBP, colors = make_color_fn(
quantile(summary_df$OBP, 0.1, na.rm = TRUE),
quantile(summary_df$OBP, 0.9, na.rm = TRUE))) %>%
data_color(columns = SLG, colors = make_color_fn(
quantile(summary_df$SLG, 0.1, na.rm = TRUE),
quantile(summary_df$SLG, 0.9, na.rm = TRUE))) %>%
data_color(columns = OPS, colors = make_color_fn(
quantile(summary_df$OPS, 0.1, na.rm = TRUE),
quantile(summary_df$OPS, 0.9, na.rm = TRUE))) %>%
data_color(columns = wOBA, colors = make_color_fn(.225, .525)) %>%
data_color(columns = `SwSpot%`, colors = make_color_fn(
quantile(summary_df$`SwSpot%`, 0.1, na.rm = TRUE),
quantile(summary_df$`SwSpot%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Hard-Hit%`, colors = make_color_fn(
quantile(summary_df$`Hard-Hit%`, 0.1, na.rm = TRUE),
quantile(summary_df$`Hard-Hit%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Barrel%`, colors = make_color_fn(
quantile(summary_df$`Barrel%`, 0.1, na.rm = TRUE),
quantile(summary_df$`Barrel%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Z-Con%`, colors = make_color_fn(
quantile(summary_df$`Z-Con%`, 0.1, na.rm = TRUE),
quantile(summary_df$`Z-Con%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Chase%`, colors = make_color_fn_reverse(
quantile(summary_df$`Chase%`, 0.1, na.rm = TRUE),
quantile(summary_df$`Chase%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Whiff%`, colors = make_color_fn_reverse(
quantile(summary_df$`Whiff%`, 0.1, na.rm = TRUE),
quantile(summary_df$`Whiff%`, 0.9, na.rm = TRUE))) %>%
fmt_number(columns = c(BA, OBP, SLG, OPS, wOBA), decimals = 3) %>%
fmt_number(columns = c(`Barrel%`, `Hard-Hit%`, `SwSpot%`, `Chase%`, `Whiff%`, `Z-Con%`), decimals = 1) %>%
fmt_missing(columns = everything(), missing_text = "-")
}
# Traditional pitching stats table from pitcher_stats
traditional_stats_pitcher <- function(pitcher_stats_df, player, season) {
ranges <- pitcher_stats %>%
filter(BF >= 50) %>%
summarise(
ERA_lo = quantile(ERA, 0.10, na.rm = TRUE),
ERA_hi = quantile(ERA, 0.90, na.rm = TRUE),
WHIP_lo = quantile(WHIP, 0.10, na.rm = TRUE),
WHIP_hi = quantile(WHIP, 0.90, na.rm = TRUE),
SO9_lo = quantile(SO9, 0.10, na.rm = TRUE),
SO9_hi = quantile(SO9, 0.90, na.rm = TRUE),
BB9_lo = quantile(BB9, 0.10, na.rm = TRUE),
BB9_hi = quantile(BB9, 0.90, na.rm = TRUE),
HR9_lo = quantile(HR9, 0.10, na.rm = TRUE),
HR9_hi = quantile(HR9, 0.90, na.rm = TRUE)
)
pitcher_stats_df %>%
filter(Name == player, Season == season) %>%
select(any_of(c("G", "GS", "W", "L", "SV", "ip", "ERA", "WHIP", "SO9", "BB9", "HR9"))) %>%
rename(IP = ip, `K/9` = SO9, `BB/9` = BB9, `HR/9` = HR9) %>%
mutate(
ERA = sprintf("%.2f", ERA),
WHIP = sprintf("%.2f", WHIP),
`K/9` = sprintf("%.1f", `K/9`),
`BB/9` = sprintf("%.1f", `BB/9`),
`HR/9` = sprintf("%.2f", `HR/9`)
) %>%
mutate(across(c(ERA, WHIP, `K/9`, `BB/9`, `HR/9`), readr::parse_number)) %>%
gt() %>%
wvu_gt_theme() %>%
data_color(columns = ERA, colors = make_color_fn_reverse(ranges$ERA_lo, ranges$ERA_hi)) %>%
data_color(columns = WHIP, colors = make_color_fn_reverse(ranges$WHIP_lo, ranges$WHIP_hi)) %>%
data_color(columns = `K/9`, colors = make_color_fn(ranges$SO9_lo, ranges$SO9_hi)) %>%
data_color(columns = `BB/9`, colors = make_color_fn_reverse(ranges$BB9_lo, ranges$BB9_hi)) %>%
data_color(columns = `HR/9`, colors = make_color_fn_reverse(ranges$HR9_lo, ranges$HR9_hi)) %>%
fmt_number(columns = c(ERA, WHIP, `HR/9`), decimals = 2) %>%
fmt_number(columns = c(`K/9`, `BB/9`), decimals = 1) %>%
fmt_missing(columns = everything(), missing_text = "-")
}
statcast_batting <- function(data, batter){
d <- data %>% filter(Batter == batter)
d %>%
filter(!is.na(TaggedPitchType)) %>%
summarise(Pitches = n(),
PA = sum(is_plate_appearance, na.rm = TRUE),
`Batted Balls` = sum(PitchCall == "InPlay", na.rm = TRUE),
`Barrels/PA` = sprintf("%.1f", 100 * (sum(is_barrel, na.rm = TRUE) / PA)),
`Barrel%` = sprintf("%.1f", 100 * (sum(is_barrel, na.rm = TRUE) / `Batted Balls`)),
EV = sprintf("%.1f", mean(ExitSpeed[PitchCall == "InPlay"] , na.rm = TRUE)),
`Max EV` = sprintf("%.1f", max(ExitSpeed[PitchCall == "InPlay"] , na.rm = TRUE)),
`SwSpot%` = sprintf("%.1f", 100 * sum(PitchCall == "InPlay" & Angle >= 8 & Angle <= 32, na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE)),
xBA = sprintf("%.3f", mean(xba, na.rm = TRUE)),
xSLG = sprintf("%.3f", mean(xslg, na.rm = TRUE)),
xwOBA = sprintf("%.3f", mean(xwOBA, na.rm = TRUE)),
wOBA = sprintf("%.3f", mean(woba, na.rm = TRUE)),
`Hard-Hit%` = sprintf("%.1f", 100 * mean(is_hard_hit, na.rm = TRUE)),
`Chase%` = sprintf("%.1f", 100 * mean(chase, na.rm = TRUE)),
`Whiff%` = sprintf("%.1f", 100 * mean(is_whiff, na.rm = TRUE)),
`Z-Con%` = sprintf("%.1f", 100 * (1- mean(in_zone_whiff, na.rm = TRUE))),
`K%` = sprintf("%.1f", 100 * mean(is_k, na.rm = TRUE)),
`BB%` = sprintf("%.1f", 100 * mean(is_walk, na.rm = TRUE))
) %>%
mutate(across(everything(), as.numeric)) %>%
gt() %>%
wvu_gt_theme() %>%
data_color(columns = xBA, colors = make_color_fn(
quantile( summary_df$xBA, 0.1, na.rm = TRUE),
quantile( summary_df$xBA, 0.9, na.rm = TRUE))) %>%
data_color(columns = xSLG, colors = make_color_fn(
quantile( summary_df$xSLG, 0.1, na.rm = TRUE),
quantile( summary_df$xSLG, 0.9, na.rm = TRUE))) %>%
data_color(columns = `SwSpot%`, colors = make_color_fn(
quantile( summary_df$`SwSpot%`, 0.1, na.rm = TRUE),
quantile( summary_df$`SwSpot%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Hard-Hit%`, colors = make_color_fn(
quantile( summary_df$`Hard-Hit%`, 0.1, na.rm = TRUE),
quantile( summary_df$`Hard-Hit%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = EV, colors = make_color_fn(
quantile( summary_df$`Avg EV`, 0.1, na.rm = TRUE),
quantile( summary_df$`Avg EV`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `K%`, colors = make_color_fn_reverse(
quantile( summary_df$`K%`, 0.1, na.rm = TRUE),
quantile( summary_df$`K%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `BB%`, colors = make_color_fn(
quantile( summary_df$`BB%`, 0.1, na.rm = TRUE),
quantile( summary_df$`BB%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Barrel%`, colors = make_color_fn(
quantile( summary_df$`Barrel%`, 0.1, na.rm = TRUE),
quantile( summary_df$`Barrel%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Barrels/PA`, colors = make_color_fn(
quantile( summary_df$`Barrels/PA`, 0.1, na.rm = TRUE),
quantile( summary_df$`Barrels/PA`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Z-Con%`, colors = make_color_fn(
quantile( summary_df$`Z-Con%`, 0.1, na.rm = TRUE),
quantile( summary_df$`Z-Con%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Max EV`, colors = make_color_fn(
quantile( summary_df$`Max EV`, 0.1, na.rm = TRUE),
quantile( summary_df$`Max EV`, 0.9, na.rm = TRUE))) %>%
data_color(columns = xwOBA, colors = make_color_fn(
quantile( summary_df$xwOBA, 0.1, na.rm = TRUE),
quantile( summary_df$xwOBA, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Chase%`, colors = make_color_fn_reverse(
quantile( summary_df$`Chase%`, 0.1, na.rm = TRUE),
quantile( summary_df$`Chase%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Whiff%`, colors = make_color_fn_reverse(
quantile( summary_df$`Whiff%`, 0.1, na.rm = TRUE),
quantile( summary_df$`Whiff%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = wOBA, colors = make_color_fn(
quantile( summary_df$xwOBA, 0.1, na.rm = TRUE),
quantile( summary_df$xwOBA, 0.9, na.rm = TRUE)))
}
hitter_summary <- function(df, player){
df <- df %>%
filter(!is.na(TaggedPitchType)) %>%
mutate(category = case_when(
TaggedPitchType %in% c("Fastball", "Cutter", "Sinker") ~ "FA",
TaggedPitchType %in% c("Slider", "Sweeper", "Curveball") ~ "BR",
TRUE ~ "OF"
))
calc_xobp <- function(.x) {
mean(.x$xba, na.rm = TRUE) +
(mean(.x$on_base, na.rm = TRUE) - mean(.x$is_hit, na.rm = TRUE))
}
hitter_summary_group <- df %>%
filter(Batter == player, PitcherThrows %in% c("Left", "Right")) %>%
group_by(category) %>%
summarise(
PA = sprintf("%.0f", sum(is_plate_appearance, na.rm = TRUE)),
xBA = sprintf("%.3f", mean(xba, na.rm = TRUE)),
xOBP = sprintf("%.3f", calc_xobp(cur_data())),
xSLG = sprintf("%.3f", mean(xslg, na.rm = TRUE)),
`Chase%` = sprintf("%.1f", 100 * mean(chase, na.rm = TRUE)),
`Whiff%` = sprintf("%.1f", 100 * mean(is_whiff, na.rm = TRUE)),
`Z-Con%` = sprintf("%.1f", 100 * (1 - mean(in_zone_whiff, na.rm = TRUE))),
`Avg EV` = sprintf("%.1f", mean(ExitSpeed[PitchCall == "InPlay"], na.rm = TRUE)),
`EV90` = sprintf("%.1f", quantile(ExitSpeed, .9, na.rm = TRUE)),
`Hard-Hit%` = sprintf("%.1f", 100 * mean(is_hard_hit, na.rm = TRUE)),
`Barrel%` = sprintf("%.1f", 100 * mean(is_barrel, na.rm = TRUE)),
`SwSpot%` = sprintf("%.1f", 100 * sum(PitchCall == "InPlay" & Angle >= 8 & Angle <= 32, na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE)),
`GB%` = sprintf("%.1f", 100 * (sum((AutoHitType == "GroundBall" & PitchCall == "InPlay"), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE))),
xwOBAcon = sprintf("%.3f", mean(xwOBA[PitchCall == "InPlay"], na.rm = TRUE)),
xwOBA = sprintf("%.3f", mean(xwOBA, na.rm = TRUE)),
wOBAcon = sprintf("%.3f", mean(woba[PitchCall == "InPlay"], na.rm = TRUE))
) %>%
mutate(across(-category, as.numeric))
hitter_summary <- df %>%
filter(Batter == player, PitcherThrows %in% c("Left", "Right")) %>%
summarise(
category = "-",
PA = sprintf("%.0f", sum(is_plate_appearance, na.rm = TRUE)),
xBA = sprintf("%.3f", mean(xba, na.rm = TRUE)),
xOBP = sprintf("%.3f", calc_xobp(cur_data())),
xSLG = sprintf("%.3f", mean(xslg, na.rm = TRUE)),
`Chase%` = sprintf("%.1f", 100 * mean(chase, na.rm = TRUE)),
`Whiff%` = sprintf("%.1f", 100 * mean(is_whiff, na.rm = TRUE)),
`Z-Con%` = sprintf("%.1f", 100 * (1 - mean(in_zone_whiff, na.rm = TRUE))),
`Avg EV` = sprintf("%.1f", mean(ExitSpeed[PitchCall == "InPlay"], na.rm = TRUE)),
`EV90` = sprintf("%.1f", quantile(ExitSpeed, .9, na.rm = TRUE)),
`Hard-Hit%` = sprintf("%.1f", 100 * mean(is_hard_hit, na.rm = TRUE)),
`Barrel%` = sprintf("%.1f", 100 * mean(is_barrel, na.rm = TRUE)),
`SwSpot%` = sprintf("%.1f", 100 * sum(PitchCall == "InPlay" & Angle >= 8 & Angle <= 32, na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE)),
`GB%` = sprintf("%.1f", 100 * (sum((AutoHitType == "GroundBall" & PitchCall == "InPlay"), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE))),
xwOBAcon = sprintf("%.3f", mean(xwOBA[PitchCall == "InPlay"], na.rm = TRUE)),
xwOBA = sprintf("%.3f", mean(xwOBA, na.rm = TRUE)),
wOBAcon = sprintf("%.3f", mean(woba[PitchCall == "InPlay"], na.rm = TRUE))
) %>%
mutate(across(-category, as.numeric))
hitter_summary_hand <- df %>%
filter(Batter == player, PitcherThrows %in% c("Left", "Right")) %>%
group_by(PitcherThrows) %>%
summarise(
PA = sprintf("%.0f", sum(is_plate_appearance, na.rm = TRUE)),
xBA = sprintf("%.3f", mean(xba, na.rm = TRUE)),
xOBP = sprintf("%.3f", calc_xobp(cur_data())),
xSLG = sprintf("%.3f", mean(xslg, na.rm = TRUE)),
`Chase%` = sprintf("%.1f", 100 * mean(chase, na.rm = TRUE)),
`Whiff%` = sprintf("%.1f", 100 * mean(is_whiff, na.rm = TRUE)),
`Z-Con%` = sprintf("%.1f", 100 * (1 - mean(in_zone_whiff, na.rm = TRUE))),
`Avg EV` = sprintf("%.1f", mean(ExitSpeed[PitchCall == "InPlay"], na.rm = TRUE)),
`EV90` = sprintf("%.1f", quantile(ExitSpeed, .9, na.rm = TRUE)),
`Hard-Hit%` = sprintf("%.1f", 100 * mean(is_hard_hit, na.rm = TRUE)),
`Barrel%` = sprintf("%.1f", 100 * mean(is_barrel, na.rm = TRUE)),
`SwSpot%` = sprintf("%.1f", 100 * sum(PitchCall == "InPlay" & Angle >= 8 & Angle <= 32, na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE)),
`GB%` = sprintf("%.1f", 100 * (sum((AutoHitType == "GroundBall" & PitchCall == "InPlay"), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE))),
xwOBAcon = sprintf("%.3f", mean(xwOBA[PitchCall == "InPlay"], na.rm = TRUE)),
xwOBA = sprintf("%.3f", mean(xwOBA, na.rm = TRUE)),
wOBAcon = sprintf("%.3f", mean(woba[PitchCall == "InPlay"], na.rm = TRUE))
) %>%
mutate(across(-PitcherThrows, as.numeric)) %>%
rename(category = PitcherThrows)
hitter_summary <- rbind(hitter_summary_group, hitter_summary_hand, hitter_summary) %>%
rename(` ` = category) %>%
mutate(` ` = ifelse(` ` == "-", "Total", ` `))
hitter_summary %>%
gt() %>%
wvu_gt_theme() %>%
data_color(columns = xBA, colors = make_color_fn(
quantile(summary_df$xBA, 0.1, na.rm = TRUE),
quantile(summary_df$xBA, 0.9, na.rm = TRUE))) %>%
data_color(columns = xOBP, colors = make_color_fn(
quantile(summary_df$OBP, 0.1, na.rm = TRUE),
quantile(summary_df$OBP, 0.9, na.rm = TRUE))) %>%
data_color(columns = xSLG, colors = make_color_fn(
quantile(summary_df$xSLG, 0.1, na.rm = TRUE),
quantile(summary_df$xSLG, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Chase%`, colors = make_color_fn_reverse(
quantile(summary_df$`Chase%`, 0.1, na.rm = TRUE),
quantile(summary_df$`Chase%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Whiff%`, colors = make_color_fn_reverse(
quantile(summary_df$`Whiff%`, 0.1, na.rm = TRUE),
quantile(summary_df$`Whiff%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Z-Con%`, colors = make_color_fn(
quantile(summary_df$`Z-Con%`, 0.1, na.rm = TRUE),
quantile(summary_df$`Z-Con%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Avg EV`, colors = make_color_fn(
quantile(summary_df$`Avg EV`, 0.1, na.rm = TRUE),
quantile(summary_df$`Avg EV`, 0.9, na.rm = TRUE))) %>%
data_color(columns = EV90, colors = make_color_fn(102, 110)) %>%
data_color(columns = `Hard-Hit%`, colors = make_color_fn(
quantile(summary_df$`Hard-Hit%`, 0.1, na.rm = TRUE),
quantile(summary_df$`Hard-Hit%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Barrel%`, colors = make_color_fn(
quantile(summary_df$`Barrel%`, 0.1, na.rm = TRUE),
quantile(summary_df$`Barrel%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `SwSpot%`, colors = make_color_fn(
quantile( summary_df$`SwSpot%`, 0.1, na.rm = TRUE),
quantile( summary_df$`SwSpot%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `GB%`, colors = make_color_fn_reverse(30, 55)) %>%
data_color(columns = xwOBA, colors = make_color_fn(
quantile(summary_df$xwOBA, 0.1, na.rm = TRUE),
quantile(summary_df$xwOBA, 0.9, na.rm = TRUE))) %>%
data_color(columns = xwOBAcon, colors = make_color_fn(
quantile(summary_df$xwOBAcon, 0.1, na.rm = TRUE),
quantile(summary_df$xwOBAcon, 0.9, na.rm = TRUE))) %>%
data_color(columns = wOBAcon, colors = make_color_fn(
quantile(summary_df$xwOBAcon, 0.1, na.rm = TRUE),
quantile(summary_df$xwOBAcon, 0.9, na.rm = TRUE))) %>%
cols_align(align = "center", columns = everything()) %>%
fmt_missing(columns = everything(), missing_text = "-")
}
batted_ball_profile <- function(data, player){
data <- data %>%
filter(!is.na(TaggedPitchType)) %>%
mutate(` ` = case_when(
TaggedPitchType %in% c("Fastball", "Cutter", "Sinker") ~ "FA",
TaggedPitchType %in% c("Slider", "Sweeper", "Curveball") ~ "BR",
TRUE ~ "OF"
))
bb_cat <- data %>%
filter(Batter == player) %>%
group_by(` `) %>%
summarise(BBE = sum(PitchCall == "InPlay", na.rm = TRUE),
`GB%` = sprintf("%.1f", 100 * (sum((AutoHitType == "GroundBall" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Air%` = sprintf("%.1f", 100 - (100 * (sum((AutoHitType == "GroundBall" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE)))),
`LD%` = sprintf("%.1f", 100 * (sum((AutoHitType == "LineDrive" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`FB%` = sprintf("%.1f", 100 * (sum((AutoHitType == "FlyBall" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`PU%` = sprintf("%.1f", 100 * (sum((AutoHitType == "Popup" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Pull%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Straight%` = sprintf("%.1f", 100 * (sum(Bearing >= -15 & Bearing <= 15 & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Oppo%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Pull GB%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) & !AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Straight GB%` = sprintf("%.1f", 100 * (sum(Bearing >= -15 & Bearing <= 15 & !AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Oppo GB%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) & !AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Pull Air%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) & AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Straight Air%` = sprintf("%.1f", 100 * (sum(Bearing >= -15 & Bearing <= 15 & AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Oppo Air%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) & AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE)))
)
bb <- data %>%
filter(Batter == player) %>%
summarise(
` ` = "-",
BBE = sum(PitchCall == "InPlay", na.rm = TRUE),
`GB%` = sprintf("%.1f", 100 * (sum((AutoHitType == "GroundBall" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Air%` = sprintf("%.1f", 100 - (100 * (sum((AutoHitType == "GroundBall" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE)))),
`LD%` = sprintf("%.1f", 100 * (sum((AutoHitType == "LineDrive" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`FB%` = sprintf("%.1f", 100 * (sum((AutoHitType == "FlyBall" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`PU%` = sprintf("%.1f", 100 * (sum((AutoHitType == "Popup" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Pull%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Straight%` = sprintf("%.1f", 100 * (sum(Bearing >= -15 & Bearing <= 15 & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Oppo%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Pull GB%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) & !AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Straight GB%` = sprintf("%.1f", 100 * (sum(Bearing >= -15 & Bearing <= 15 & !AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Oppo GB%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) & !AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Pull Air%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) & AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Straight Air%` = sprintf("%.1f", 100 * (sum(Bearing >= -15 & Bearing <= 15 & AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Oppo Air%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) & AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE)))
)
bb_hand <- data %>%
filter(Batter == player) %>%
group_by(PitcherThrows) %>%
summarise(
BBE = sum(PitchCall == "InPlay", na.rm = TRUE),
`GB%` = sprintf("%.1f", 100 * (sum((AutoHitType == "GroundBall" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Air%` = sprintf("%.1f", 100 - (100 * (sum((AutoHitType == "GroundBall" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE)))),
`LD%` = sprintf("%.1f", 100 * (sum((AutoHitType == "LineDrive" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`FB%` = sprintf("%.1f", 100 * (sum((AutoHitType == "FlyBall" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`PU%` = sprintf("%.1f", 100 * (sum((AutoHitType == "Popup" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Pull%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Straight%` = sprintf("%.1f", 100 * (sum(Bearing >= -15 & Bearing <= 15 & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Oppo%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Pull GB%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) & !AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Straight GB%` = sprintf("%.1f", 100 * (sum(Bearing >= -15 & Bearing <= 15 & !AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Oppo GB%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) & !AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Pull Air%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) & AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Straight Air%` = sprintf("%.1f", 100 * (sum(Bearing >= -15 & Bearing <= 15 & AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Oppo Air%` = sprintf("%.1f", 100 * (sum(if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) & AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE)))
) %>%
rename(` ` = PitcherThrows)
summary <- rbind(bb_cat, bb_hand, bb)
summary <- summary %>%
mutate(`Pull Air%` = as.numeric(`Pull Air%`),
`Air%` = as.numeric(`Air%`)) %>%
mutate(` ` = ifelse(` ` == "-", "Total", ` `))
summary %>%
gt() %>%
wvu_gt_theme() %>%
fmt_missing(columns = everything(), missing_text = "-") %>%
data_color(columns = `Pull Air%`, colors = make_color_fn(
quantile( summary_df$`Pull Air%`, 0.1, na.rm = TRUE),
quantile( summary_df$`Pull Air%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Air%`, colors = make_color_fn(
100 - quantile(summary_df_pitcher$`GB%`, 0.9, na.rm = TRUE),
100 - quantile(summary_df_pitcher$`GB%`, 0.1, na.rm = TRUE)))
}
plate_discipline <- function(data, batter){
data %>%
filter(Batter == batter) %>%
summarise(`Zone%` = sprintf("%.1f", 100 * mean(in_zone, na.rm = TRUE)),
`Swing%` = sprintf("%.1f",100 * mean(is_swing, na.rm = TRUE)),
`FPSwing%` = sprintf("%.1f",100 * mean(is_swing[Balls == 0 & Strikes == 0], na.rm = TRUE)),
`Z-Swing%` = sprintf("%.1f", 100 * mean(is_swing[in_zone == 1], na.rm = TRUE)),
`Z-Con%` = sprintf("%.1f", 100 * (1- mean(in_zone_whiff, na.rm = TRUE))),
`O-Swing%` = sprintf("%.1f", 100 * mean(chase, na.rm = TRUE)),
`O-Con%` = sprintf("%.1f", 100 * (1 - mean(is_whiff[in_zone == 0], na.rm = TRUE))),
`Decision Runs` = sprintf("%.2f", 100 * mean(sd_rv_added, na.rm = TRUE))
) %>%
mutate(across(everything(), as.numeric)) %>%
gt() %>%
wvu_gt_theme() %>%
fmt_missing(columns = everything(), missing_text = "-") %>%
data_color(columns = `Z-Swing%`, colors = make_color_fn(
quantile( summary_df$`Z-Swing%`, 0.1, na.rm = TRUE),
quantile( summary_df$`Z-Swing%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Z-Con%`, colors = make_color_fn(
quantile( summary_df$`Z-Con%`, 0.1, na.rm = TRUE),
quantile( summary_df$`Z-Con%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Swing%`, colors = make_color_fn(
quantile( summary_df$`Swing%`, 0.1, na.rm = TRUE),
quantile( summary_df$`Swing%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `FPSwing%`, colors = make_color_fn(
quantile( summary_df$`FPSwing%`, 0.1, na.rm = TRUE),
quantile( summary_df$`FPSwing%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `O-Con%`, colors = make_color_fn(
quantile( summary_df$`O-Con%`, 0.1, na.rm = TRUE),
quantile( summary_df$`O-Con%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Decision Runs`, colors = make_color_fn(
quantile( summary_df$Decisions, 0.1, na.rm = TRUE),
quantile( summary_df$Decisions, 0.9, na.rm = TRUE))) %>%
data_color(columns = `O-Swing%`, colors = make_color_fn_reverse(
quantile( summary_df$`Chase%`, 0.1, na.rm = TRUE),
quantile( summary_df$`Chase%`, 0.9, na.rm = TRUE)))
}
get_spider <- function(hitter_stats, batter_name, season, batter_ids = NULL) {
hs_season <- hitter_stats %>%
dplyr::filter(Season == season)
grade_metrics <- hs_season %>%
dplyr::mutate(
xPowerFactor = xSLG / xBA,
xISO = xSLG - xBA
) %>%
dplyr::summarise(
sdrv_mean = mean(decisions, na.rm = TRUE),
sdrv_sd = sd(decisions, na.rm = TRUE),
xpf_mean = mean(xPowerFactor, na.rm = TRUE),
xpf_sd = sd(xPowerFactor, na.rm = TRUE),
iso_mean = mean(xISO, na.rm = TRUE),
iso_sd = sd(xISO, na.rm = TRUE),
ev90_mean = mean(ev90, na.rm = TRUE),
ev90_sd = sd(ev90, na.rm = TRUE),
k_mean = mean(k_pct, na.rm = TRUE),
k_sd = sd(k_pct, na.rm = TRUE),
zone_con_mean = mean(z_contact_pct, na.rm = TRUE),
zone_con_sd = sd(z_contact_pct, na.rm = TRUE),
xba_mean = mean(xBA, na.rm = TRUE),
xba_sd = sd(xBA, na.rm = TRUE),
whiff_mean = mean(whiff_pct, na.rm = TRUE),
whiff_sd = sd(whiff_pct, na.rm = TRUE)
)
batter_split <- filter_rows_by_selection(
hs_season,
"Name",
batter_name,
batter_ids,
id_col = "Id",
team_cols = c("Team", "team_name")
) %>%
dplyr::mutate(
xPowerFactor = xSLG / xBA,
xISO = xSLG - xBA,
ISO = xISO, # keep naming consistent with your downstream formula
sdrv = decisions, # Swing Decisions uses decisions directly (already a season stat)
zone_con = z_contact_pct, # zone_con in your plot is zone contact rate
`K%` = k_pct,
whiff_pct = whiff_pct,
ev90 = ev90
) %>%
dplyr::slice(1) %>% # just in case duplicates
dplyr::rowwise() %>%
dplyr::mutate(
`Swing Decisions` = ((sdrv - grade_metrics$sdrv_mean) / grade_metrics$sdrv_sd) * 10 + 50,
`Game Power` = (((xPowerFactor - grade_metrics$xpf_mean) / grade_metrics$xpf_sd) +
((ISO - grade_metrics$iso_mean) / grade_metrics$iso_sd)) * 5 + 50,
`Raw Power` = ((ev90 - grade_metrics$ev90_mean) / grade_metrics$ev90_sd) * 10 + 50,
`Avoid K` = (((grade_metrics$k_mean - `K%`) / grade_metrics$k_sd) +
((grade_metrics$whiff_mean - whiff_pct) / grade_metrics$whiff_sd)) * 5 + 50,
Contact = (((zone_con - grade_metrics$zone_con_mean) / grade_metrics$zone_con_sd) +
((xBA - grade_metrics$xba_mean) / grade_metrics$xba_sd)) * 5 + 50,
group = "Overall"
) %>%
dplyr::ungroup() %>%
dplyr::mutate(
dplyr::across(
c(`Swing Decisions`, `Game Power`, `Raw Power`, `Avoid K`, Contact),
~ round(pmax(pmin(., 80), 20))
)
)
radar_data <- batter_split %>%
dplyr::select(group, `Swing Decisions`, `Raw Power`, `Game Power`, `Avoid K`, Contact) %>%
tidyr::pivot_longer(-group, names_to = "metric", values_to = "value") %>%
dplyr::mutate(metric = factor(metric, levels = c("Swing Decisions", "Raw Power", "Game Power", "Avoid K", "Contact")))
n_metrics <- 5
angles <- seq(0, 2*pi, length.out = n_metrics + 1)[1:n_metrics]
radar_data <- radar_data %>%
dplyr::mutate(
angle = angles[as.numeric(metric)],
x = value * cos(angle - pi/2),
y = value * sin(angle - pi/2)
)
grid_df <- data.frame(r = c(20, 50, 80)) %>%
dplyr::rowwise() %>%
dplyr::mutate(data = list({
ang <- seq(0, 2*pi, length.out = 100)
data.frame(
angle = ang,
x = r * cos(ang - pi/2),
y = r * sin(ang - pi/2)
)
})) %>%
tidyr::unnest(data) %>%
dplyr::ungroup()
axis_df <- data.frame(
metric = c("Swing Decisions", "Raw Power", "Game Power", "Avoid K", "Contact"),
angle = angles
) %>%
dplyr::mutate(
x_end = 85 * cos(angle - pi/2),
y_end = 85 * sin(angle - pi/2),
x_lab = 95 * cos(angle - pi/2),
y_lab = 95 * sin(angle - pi/2)
)
ggplot2::ggplot() +
ggplot2::geom_path(data = grid_df, ggplot2::aes(x = x, y = y, group = r),
color = "grey80", linetype = "dashed") +
ggplot2::geom_segment(data = axis_df, ggplot2::aes(x = 0, y = 0, xend = x_end, yend = y_end),
color = "grey60") +
ggplot2::geom_polygon(data = radar_data, ggplot2::aes(x = x, y = y, group = group),
fill = "#002855", alpha = 0.3) +
ggplot2::geom_path(data = radar_data, ggplot2::aes(x = x, y = y, group = group),
color = "#002855", linewidth = 1) +
ggplot2::geom_point(data = radar_data, ggplot2::aes(x = x, y = y),
color = "#002855", size = 3) +
ggplot2::geom_text(data = axis_df, ggplot2::aes(x = x_lab, y = y_lab, label = metric),
size = 3.5) +
ggplot2::annotate("text", x = 0, y = c(20, 50, 80),
label = c("20", "50", "80"), size = 3, color = "grey50") +
ggplot2::coord_fixed() +
ggplot2::theme_void() +
ggplot2::theme(
legend.position = "none"
)
}
contact_pos <- function(data, player, season = NULL){
filtered_data <- data %>%
filter(Batter == player)
if (!is.null(season)) {
filtered_data <- filtered_data %>%
filter(Season == season)
}
if (nrow(filtered_data) == 0) {
return(ggplot() + theme_void())
}
filtered_data %>%
drop_na(ContactPositionX, ContactPositionY, ContactPositionZ) %>%
mutate(ContactPositionX = ContactPositionX * 12,
ContactPositionZ = ContactPositionZ * 12,
ContactPositionY = ContactPositionY * 12) %>%
mutate(PlayResult = case_when(
PlayResult %in% c("FieldersChoice", "Error", "Sacrifice") ~ "Out",
TRUE ~ PlayResult
),
color_scale = case_when(
PitchCall == "InPlay" & is_hard_hit == 1 ~ "Hard Hit",
PitchCall == "InPlay" & is_hard_hit == 0 ~ "Weak Hit",
PitchCall != "InPlay" ~ "Foul Ball"
)) %>%
ggplot(aes(ContactPositionZ, ContactPositionX)) +
geom_segment(aes(x = -8.5, y = 17, xend = 8.5, yend = 17), color = "black") +
geom_segment(aes(x = 8.5, y = 8.5, xend = 8.5, yend = 17), color = "black") +
geom_segment(aes(x = -8.5, y = 8.5, xend = -8.5, yend = 17), color = "black") +
geom_segment(aes(x = -8.5, y = 8.5, xend = 0, yend = 0), color = "black") +
geom_segment(aes(x = 8.5, y = 8.5, xend = 0, yend = -0), color = "black") +
geom_rect(aes(xmin = 20, xmax = 48, ymin = -20, ymax = 40), fill = NA, color = "black") +
geom_rect(aes(xmin = -48, xmax = -20, ymin = -20, ymax = 40), fill = NA, color = "black") +
geom_text(aes(x = ifelse(BatterSide == "Right", -34, 34), y = 10,
label = ifelse(BatterSide == "Right", "R", "L")) , size = 8, fontface = "bold") +
xlim(-50, 50) + ylim(-20, 50) +
geom_point(aes(fill = factor(color_scale)), color = "black", stroke = 0.5, shape = 21, alpha = 0.8, size = 3) +
scale_fill_manual(
name = " ",
values = c("Hard Hit" = "#d72029", "Weak Hit" = "white", "Foul Ball" = "lightgrey")
) +
coord_fixed() +
theme_void() +
facet_wrap(~ BatterSide) +
theme(legend.position = "top",
strip.text = element_blank()
)
}
pitcher_percentiles <- function(df, pitcher, season = NULL, pitcher_ids = NULL, pitcher_stats_df = pitcher_stats) {
# Use pre-computed stats from pitcher_stats instead of computing from df
df <- filter_out_scrimmage_dates(df)
pitcher_data <- filter_rows_by_selection(df, "Pitcher", pitcher, pitcher_ids, id_col = "PitcherId", team_cols = c("PitcherTeam"))
if (!is.null(season)) {
pitcher_data <- pitcher_data %>% filter(Season == season)
}
season_extension_df <- pool_pbp(df, season) %>%
dplyr::filter(!is.na(Pitcher)) %>%
dplyr::group_by(Pitcher) %>%
dplyr::summarise(
Extension = mean(Extension, na.rm = TRUE),
.groups = "drop"
) %>%
dplyr::mutate(Extension = ifelse(is.nan(Extension), NA_real_, Extension))
pitcher_row <- filter_rows_by_selection(
pitcher_stats_df,
"Name",
pitcher,
pitcher_ids,
id_col = "Id",
team_cols = c("Team", "team_name")
)
if (!is.null(season)) {
pitcher_row <- pitcher_row %>% filter(Season == season)
}
pitcher_row <- pitcher_row %>%
slice(1) # Take first row if multiple seasons
season_summary_df_pitcher <- pitcher_stats_df %>%
{ if (!is.null(season)) dplyr::filter(., Season == pool_season(season)) else . } %>%
dplyr::filter(BF >= 50) %>%
dplyr::transmute(
Name = Name,
xBA = xBA,
xwOBA = xwOBA,
Stuff = stuff,
`FB Velo` = fb_velo,
`Avg EV` = avg_ev,
`Barrel%` = barrel_pct,
`Hard-Hit%` = hard_hit_pct,
`GB%` = gb_pct,
`Chase%` = chase_pct,
Decisions = decisions,
`Whiff%` = whiff_pct,
`Z-Whiff%` = z_whiff_pct,
`K%` = 100 * SO / BF,
`BB%` = 100 * BB / BF
) %>%
dplyr::left_join(season_extension_df, by = c("Name" = "Pitcher")) %>%
dplyr::select(-Name)
if (nrow(season_summary_df_pitcher) == 0) {
season_domain_data <- pool_pbp(df, season) %>%
dplyr::filter(!is.na(Pitcher))
season_summary_df_pitcher <- season_domain_data %>%
dplyr::group_by(Pitcher) %>%
dplyr::summarise(
xBA = mean(xba, na.rm = TRUE),
xwOBA = mean(xwOBA, na.rm = TRUE),
Stuff = mean(stuff, na.rm = TRUE),
`FB Velo` = mean(RelSpeed[TaggedPitchType == "Fastball"], na.rm = TRUE),
`Avg EV` = mean(ExitSpeed, na.rm = TRUE),
`Barrel%` = 100 * mean(is_barrel, na.rm = TRUE),
`Hard-Hit%` = 100 * mean(is_hard_hit, na.rm = TRUE),
`GB%` = 100 * sum(AutoHitType == "GroundBall" & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Chase%` = 100 * mean(chase, na.rm = TRUE),
Decisions = -100 * mean(sd_rv_added, na.rm = TRUE),
`Whiff%` = 100 * mean(is_whiff, na.rm = TRUE),
`Z-Whiff%` = 100 * mean(in_zone_whiff, na.rm = TRUE),
`K%` = 100 * mean(is_k, na.rm = TRUE),
`BB%` = 100 * mean(is_walk, na.rm = TRUE),
Extension = mean(Extension, na.rm = TRUE),
.groups = "drop"
) %>%
dplyr::select(-Pitcher) %>%
dplyr::mutate(dplyr::across(dplyr::everything(), ~ ifelse(is.nan(.x), NA_real_, .x)))
}
if (nrow(season_summary_df_pitcher) == 0) {
return(blank_percentile_plot("Pitching"))
}
if (nrow(pitcher_row) == 0 && nrow(pitcher_data) == 0) {
return(blank_percentile_plot("Pitching"))
}
if (nrow(pitcher_row) == 0) {
# Fallback to computing from df if not found in pitcher_stats
pitcher_split <- pitcher_data %>%
summarise(
xBA = sprintf("%.3f", mean(xba, na.rm = TRUE)),
xwOBA = sprintf("%.3f", mean(xwOBA, na.rm = TRUE)),
Stuff = round(mean(stuff, na.rm = TRUE)),
`FB Velo` = sprintf("%.1f", mean(RelSpeed[TaggedPitchType == "Fastball"], na.rm = TRUE)),
`Avg EV` = sprintf("%.1f", mean(ExitSpeed, na.rm = TRUE)),
`Barrel%` = sprintf("%.1f", 100 * mean(is_barrel, na.rm = TRUE)),
`Hard-Hit%` = sprintf("%.1f", 100 * mean(is_hard_hit, na.rm = TRUE)),
`GB%` = sprintf("%.1f", 100 * (sum(AutoHitType == "GroundBall" & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE))),
`Chase%` = sprintf("%.1f", 100 * mean(chase, na.rm = TRUE)),
Decisions = sprintf("%.2f", -100 * mean(sd_rv_added, na.rm = TRUE)),
`Whiff%` = sprintf("%.1f", 100 * mean(is_whiff, na.rm = TRUE)),
`Z-Whiff%` = sprintf("%.1f", 100 * mean(in_zone_whiff, na.rm = TRUE)),
`K%` = sprintf("%.1f", 100 * mean(is_k, na.rm = TRUE)),
`BB%` = sprintf("%.1f", 100 * mean(is_walk, na.rm = TRUE)),
Extension = sprintf("%.1f", mean(Extension, na.rm = TRUE)),
.groups = "drop"
) %>%
mutate(across(everything(), as.numeric))
} else {
# Use pre-computed stats from pitcher_stats (already in percentage form)
pitcher_split <- tibble(
xBA = pitcher_row$xBA,
xwOBA = pitcher_row$xwOBA,
Stuff = round(pitcher_row$stuff),
`FB Velo` = pitcher_row$fb_velo,
`Avg EV` = pitcher_row$avg_ev,
`Barrel%` = pitcher_row$barrel_pct,
`Hard-Hit%` = pitcher_row$hard_hit_pct,
`GB%` = pitcher_row$gb_pct,
`Chase%` = pitcher_row$chase_pct,
Decisions = pitcher_row$decisions,
`Whiff%` = pitcher_row$whiff_pct,
`Z-Whiff%` = pitcher_row$z_whiff_pct,
`K%` = 100 * pitcher_row$SO / pitcher_row$BF,
`BB%` = 100 * pitcher_row$BB / pitcher_row$BF,
Extension = NA_real_ # Extension not in pitcher_stats, compute from df if needed
)
# Get extension from df if not available
if (is.na(pitcher_split$Extension)) {
ext <- pitcher_data %>%
summarise(Extension = mean(Extension, na.rm = TRUE)) %>%
pull(Extension)
if (is.na(ext) || is.nan(ext)) {
ext <- filter_rows_by_selection(
df,
"Pitcher",
pitcher,
pitcher_ids,
id_col = "PitcherId",
team_cols = c("PitcherTeam")
) %>%
summarise(Extension = mean(Extension, na.rm = TRUE)) %>%
pull(Extension)
}
if (is.nan(ext)) ext <- NA_real_
pitcher_split$Extension <- ext
}
}
pitcher_split <- pitcher_split %>%
mutate(across(everything(), ~ ifelse(is.nan(.x), NA_real_, .x)))
if (all(is.na(unlist(pitcher_split)))) {
return(blank_percentile_plot("Pitching"))
}
percentile_df <- pitcher_split %>%
pivot_longer(everything(), names_to = "Metric", values_to = "Value") %>%
mutate(
Percentile = purrr::map2_dbl(Metric, Value, function(m, v) {
vals <- season_summary_df_pitcher[[m]]
if (m == "Extension") {
vals <- c(4.5, 7.5)
} else if (is.null(vals) || all(is.na(vals))) {
return(NA_real_)
}
if (m %in% c("xBA", "xwOBA", "Avg EV", "Barrel%", "Hard-Hit%", "BB%")) {
mean(vals >= v, na.rm = TRUE) * 100
} else {
mean(vals <= v, na.rm = TRUE) * 100
}
}),
Fill = gradient_n_pal(c("#315aa1", "#b4cfd0", "#d72029"))(Percentile / 100)
) %>%
mutate(
Percentile = ifelse(is.nan(Percentile), NA_real_, Percentile),
Value = ifelse(is.nan(Value), NA_real_, Value)
) %>%
filter(!is.na(Value)) %>%
mutate(
Value = case_when(
Metric %in% c("xwOBA", "xBA") ~ sprintf("%.3f", Value),
Metric == "SD Runs" ~ sprintf("%.2f", Value),
Metric == "Stuff" ~ as.character(round(Value)),
TRUE ~ sprintf("%.1f", Value)
)
)
if (nrow(percentile_df) == 0) {
return(blank_percentile_plot("Pitching"))
}
percentile_points <- percentile_df %>% filter(!is.na(Percentile))
ggplot(percentile_df, aes(y = factor(Metric, levels = rev(Metric)))) +
geom_tile(aes(x = 50, width = 100), fill = "#c7dcdc", alpha = 0.3, height = 0.25) +
geom_tile(aes(x = Percentile / 2, width = Percentile, fill = Fill), height = 0.7) +
geom_text(aes(x = -3, label = Metric), hjust = 1, size = 5.25) +
geom_text(aes(x = 103, label = Value), hjust = 0, size = 5.25) +
geom_point(data = percentile_points, aes(x = Percentile), color = "white", size = 10, shape = 21, stroke = 2.25, fill = percentile_points$Fill) +
geom_text(data = percentile_points, aes(x = Percentile, label = round(Percentile)), size = 4, color = "white", fontface = "bold") +
geom_segment(aes(x = -2, xend = -16,
y = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3,
yend = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3),
linetype = "longdash", color = "#399098", size = 1) +
geom_segment(aes(x = 102, xend = 113,
y = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3,
yend = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3),
linetype = "longdash", color = "#399098", size = 1) +
scale_x_continuous(limits = c(-16, 113), expand = c(0, 0)) +
scale_fill_identity() +
theme_minimal() +
ggtitle("Pitching") +
theme(
plot.title = element_text(hjust = .5, face = "bold"),
panel.background = element_rect(fill = "white"),
axis.text = element_blank(),
axis.title = element_blank(),
panel.grid = element_blank()
)
}
value_percentiles_pitcher <- function(pitcher, pit_war, df, season, pitcher_ids = NULL) {
df <- filter_out_scrimmage_dates(df)
season_pit_war <- pit_war %>%
filter(Season == season)
pitcher_war <- filter_rows_by_selection(
season_pit_war,
"Pitcher",
pitcher,
pitcher_ids,
id_col = "Id",
team_cols = c("PitcherTeam")
) %>%
filter(Season == season)
if (nrow(pitcher_war) == 0) {
return(blank_percentile_plot("Value"))
}
pitcher_split <- pitcher_war %>%
summarise(
WAR = round(sum(WAR, na.rm = TRUE), 1),
`WAR/100` = round(first(`WAR/100`), 1),
FIP = round(first(FIP), 1),
.groups = "drop"
) %>%
mutate(across(everything(), as.numeric))
# Use average Stuff+ by pitch category instead of run values
pitch_split_pitches <- filter_rows_by_selection(
df,
"Pitcher",
pitcher,
pitcher_ids,
id_col = "PitcherId",
team_cols = c("PitcherTeam")
) %>%
filter(!is.na(stuff), Season == season) %>%
mutate(category = case_when(
TaggedPitchType %in% c("Fastball", "Cutter", "Sinker") ~ "FA",
TaggedPitchType %in% c("Slider", "Sweeper", "Curveball") ~ "BR",
TRUE ~ "OF"
)) %>%
group_by(category) %>%
summarise(avg_stuff = round(mean(stuff, na.rm = TRUE)), .groups = "drop") %>%
pivot_wider(names_from = category, values_from = avg_stuff, values_fill = NA_real_) %>%
rename_with(~ paste0(., " Stuff+"), everything()) %>%
mutate(across(everything(), as.numeric))
if (nrow(pitch_split_pitches) == 0) {
pitch_split_pitches <- tibble(
`FA Stuff+` = NA_real_,
`BR Stuff+` = NA_real_,
`OF Stuff+` = NA_real_
)
}
for (col in c("FA Stuff+", "BR Stuff+", "OF Stuff+")) {
if (!col %in% names(pitch_split_pitches)) {
pitch_split_pitches[[col]] <- NA_real_
}
}
pitch_split_pitches <- pitch_split_pitches %>%
select(`FA Stuff+`, `BR Stuff+`, `OF Stuff+`)
pitcher_split <- cbind(pitcher_split, pitch_split_pitches)
season_pitcher_stuff <- pitcher_stats %>%
dplyr::filter(Season == season, BF >= 50)
if (nrow(season_pitcher_stuff) == 0) {
return(blank_percentile_plot("Value"))
}
pit_comp_idx <- season_pit_war$IP >= 20
if (!any(pit_comp_idx, na.rm = TRUE)) pit_comp_idx <- season_pit_war$IP >= 10
if (!any(pit_comp_idx, na.rm = TRUE)) pit_comp_idx <- season_pit_war$IP >= 5
if (!any(pit_comp_idx, na.rm = TRUE)) pit_comp_idx <- !is.na(season_pit_war$IP)
percentile_df <- pitcher_split %>%
pivot_longer(everything(), names_to = "Metric", values_to = "Value") %>%
mutate(
Percentile = purrr::map2_dbl(Metric, Value, function(m, v) {
if (is.na(v) || is.nan(v)) return(NA_real_)
vals <- if(m %in% c("WAR", "WAR/100", "FIP")){
season_pit_war[[m]][pit_comp_idx]
} else {
# For Stuff+ metrics, compare within this season's pitcher cohort
season_pitcher_stuff$stuff
}
if (is.null(vals) || all(is.na(vals))) return(NA_real_)
if (m == "FIP") {
mean(vals >= v, na.rm = TRUE) * 100
} else {
mean(vals <= v, na.rm = TRUE) * 100
}
}),
ValueLabel = dplyr::if_else(is.na(Value) | is.nan(Value), "", as.character(Value)),
Fill = gradient_n_pal(c("#315aa1", "#b4cfd0", "#d72029"))(Percentile / 100)
)
if (nrow(percentile_df) == 0) {
return(blank_percentile_plot("Value"))
}
percentile_points <- percentile_df %>% filter(!is.na(Percentile), !is.nan(Percentile))
percentile_fill <- percentile_df %>% filter(!is.na(Percentile), !is.nan(Percentile))
ggplot(percentile_df, aes(y = factor(Metric, levels = rev(Metric)))) +
geom_tile(aes(x = 50, width = 100), fill = "#c7dcdc", alpha = 0.3, height = 0.25) +
geom_tile(data = percentile_fill, aes(x = Percentile / 2, width = Percentile, fill = Fill), height = 0.7) +
geom_text(aes(x = -3, label = Metric), hjust = 1, size = 5.25) +
geom_text(aes(x = 103, label = ValueLabel), hjust = 0, size = 5.25) +
geom_point(data = percentile_points, aes(x = Percentile), color = "white", size = 10, shape = 21, stroke = 2.25, fill = percentile_points$Fill) +
geom_text(data = percentile_points, aes(x = Percentile, label = round(Percentile)), size = 4, color = "white", fontface = "bold") +
geom_segment(aes(x = -2, xend = -16,
y = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3,
yend = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3),
linetype = "longdash", color = "#399098", size = 1) +
geom_segment(aes(x = 102, xend = 113,
y = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3,
yend = as.numeric(factor(Metric, levels = rev(Metric))) - 0.3),
linetype = "longdash", color = "#399098", size = 1) +
scale_x_continuous(limits = c(-16, 113), expand = c(0, 0)) +
scale_fill_identity() +
theme_minimal() +
ggtitle("Value") +
theme(plot.title = element_text(hjust = .5, face = "bold"),
panel.background = element_rect(fill = "white"),
axis.text = element_blank(),
axis.title = element_blank(),
panel.grid = element_blank()
)
}
movement <- function(df, player, show_legend = TRUE) {
df <- df %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
group_by(TaggedPitchType) %>%
mutate(n = 100 * n() / nrow( df %>%
filter(Pitcher == player))) %>%
filter(n >= 1) %>%
ungroup()
df <- df %>%
group_by(BatterSide) %>%
mutate(mean_RelSide = mean(RelSide, na.rm = TRUE)) %>%
ungroup() %>%
filter((abs(RelSide) - abs(mean_RelSide)) < .5)
velo_data <- df %>%
group_by(TaggedPitchType) %>%
summarise(mean_velo = round(mean(RelSpeed, na.rm = TRUE)),
mean_hb = median(HorzBreak, na.rm = TRUE),
mean_ivb = median(InducedVertBreak, na.rm = TRUE))
arm_angle_layer <- list()
movement_title <- "Short Form Movement"
if ("arm_angle" %in% names(df)) {
arm_angle_vals <- suppressWarnings(as.numeric(df$arm_angle))
if (any(is.finite(arm_angle_vals))) {
arm_angle_deg <- median(arm_angle_vals[is.finite(arm_angle_vals)], na.rm = TRUE)
arm_angle_deg <- max(min(arm_angle_deg, 90), 0)
movement_title <- paste0("Short Form Movement (Arm Angle: ", round(arm_angle_deg), "\u00b0)")
throw_hand <- NA_character_
if ("PitcherThrows" %in% names(df)) {
throw_vals <- as.character(df$PitcherThrows)
throw_vals <- throw_vals[!is.na(throw_vals) & throw_vals != ""]
if (length(throw_vals) > 0) {
throw_hand <- throw_vals[1]
}
}
is_lefty <- tolower(substr(throw_hand, 1, 1)) == "l"
if (isTRUE(all.equal(arm_angle_deg, 90, tolerance = 1e-6))) {
arm_angle_layer <- list(
annotate("segment", x = 0, y = -27.5, xend = 0, yend = 27.5,
linetype = "dashed", color = "gray35", size = 0.8)
)
} else {
slope <- tan(arm_angle_deg * pi / 180)
if (is_lefty) slope <- -slope
arm_angle_layer <- list(
geom_abline(slope = slope, intercept = 0, linetype = "dashed", color = "gray35", size = 0.8)
)
}
}
}
plot <- df %>%
filter(Pitcher == player) %>%
ggplot(aes(x = HorzBreak, y = InducedVertBreak)) +
geom_segment(aes(x = 0, y = -25, xend = 0, yend = 25), color = "black", linetype = "dashed") +
geom_segment(aes(x = -25, y = 0, xend = 25, yend = 0), color = "black", linetype = "dashed") +
arm_angle_layer +
geom_point(aes(fill = TaggedPitchType), alpha = .5, shape = 21, color = "black", stroke = .5, size = 3.5) +
geom_point(data = velo_data,
aes(x = mean_hb, y = mean_ivb,
fill = TaggedPitchType), alpha = 1, shape = 21, color = "black", stroke = .5, size = 8) +
geom_text(
data = velo_data,
aes(x = mean_hb, y = mean_ivb, label = mean_velo),
color = "white",
size = 4,
hjust = 0.5) +
annotate("text", x = -26.5, y = 27.5,
label = "← 1B", color = "black", size = 3, hjust = 0.5) +
annotate("text", x = 26.5, y = 27.5,
label = "3B →", color = "black", size = 3, hjust = 0.5) +
scale_x_continuous("Horizontal Movement (in)", limits = c(-27.5, 27.5), breaks = seq(-20, 20, by = 10)) +
scale_y_continuous("Induced Vertical Movement (in)", limits = c(-27.5, 27.5), breaks = seq(-20, 20, by = 10)) +
scale_fill_manual(values = pitch_colors) +
scale_color_manual(values = pitch_colors) +
coord_equal() +
theme_minimal() +
ggtitle(movement_title) +
theme(plot.title = element_text(hjust = .5, size = 12),
panel.background = element_rect(fill = "#ffffff"),
legend.title = element_blank(),
axis.text.x = element_text(size = 12),
axis.text.y = element_text(size = 12),
axis.title.x = element_text(size = 12),
axis.title.y = element_text(size = 12)
)
if (show_legend == TRUE){
plot <- plot +
theme(legend.position = "right")
} else{
plot <- plot +
theme(legend.position = "none")
}
plot
}
pitch_summary_overall <- function(data, player, season, pitcher_stats_df = NULL, pitcher_ids = NULL) {
data <- filter_rows_by_selection(data, "Pitcher", player, pitcher_ids, id_col = "PitcherId", team_cols = c("PitcherTeam"))
trackman_summary <- data %>%
summarise(
IP = round(sum(OutsOnPlay, na.rm = TRUE) / 3, 2),
H = sum(is_hit, na.rm = TRUE),
BB = sum(is_walk, na.rm = TRUE),
R = sum(RunsScored, na.rm = TRUE),
HR = sum(PlayResult == "Homerun", na.rm = TRUE),
BBE = sum(PitchCall == "InPlay", na.rm = TRUE),
`Strike%` = 100 * sum(!PitchCall %in% c("BallCalled", "HitByPitch", "BallinDirt", "BallIntentional", "Undefined")) / n(),
`CSW%` = 100 * mean(is_csw, na.rm = TRUE),
`Chase%` = 100 * mean(chase, na.rm = TRUE),
`Zone%` = 100 * mean(in_zone, na.rm = TRUE),
`Whiff%` = 100 * mean(is_whiff, na.rm = TRUE),
`Z-Whiff%` = 100 * mean(in_zone_whiff, na.rm = TRUE),
`Put Away%` = 100 * mean(is_put_away, na.rm = TRUE),
`Barrel%` = 100 * mean(is_barrel, na.rm = TRUE),
xwOBA = mean(xwOBA, na.rm = TRUE),
Stuff = mean(stuff, na.rm = TRUE)
) %>%
mutate(
ERA = if_else(IP > 0, 9 * R / IP, NA_real_),
WHIP = if_else(IP > 0, (H + BB) / IP, NA_real_),
`H/9` = if_else(IP > 0, 9 * H / IP, NA_real_),
`K/9` = if_else(IP > 0, 9 * sum(data$is_k, na.rm = TRUE) / IP, NA_real_),
`BB/9` = if_else(IP > 0, 9 * BB / IP, NA_real_),
`R/9` = if_else(IP > 0, 9 * R / IP, NA_real_),
`HR/9` = if_else(IP > 0, 9 * HR / IP, NA_real_)
) %>%
mutate(IP = case_when(
abs(IP %% 1 - 0.33) < 0.01 ~ floor(IP) + 0.1,
abs(IP %% 1 - 0.67) < 0.01 ~ floor(IP) + 0.2,
TRUE ~ IP
)) %>%
ungroup()
stats_row <- tibble()
if (!is.null(pitcher_stats_df)) {
stats_row <- filter_rows_by_selection(
pitcher_stats_df,
"Name",
player,
pitcher_ids,
id_col = "Id",
team_cols = c("Team", "team_name")
) %>%
filter(Season == season) %>%
slice_head(n = 1)
}
stats_ip <- NA_real_
stats_whip <- NA_real_
stats_h9 <- NA_real_
stats_so9 <- NA_real_
stats_bb9 <- NA_real_
stats_hr9 <- NA_real_
if (nrow(stats_row)) {
to_num1 <- function(col) {
if (!(col %in% names(stats_row)) || length(stats_row[[col]]) == 0) return(NA_real_)
suppressWarnings(as.numeric(stats_row[[col]][[1]]))
}
stats_ip <- dplyr::coalesce(to_num1("ip"), to_num1("IP"))
stats_h <- to_num1("H")
stats_bb <- to_num1("BB")
stats_so <- dplyr::coalesce(to_num1("SO"), to_num1("K"))
stats_hr <- to_num1("HR")
stats_whip <- dplyr::coalesce(to_num1("WHIP"),
if (is.finite(stats_ip) && stats_ip > 0) (stats_h + stats_bb) / stats_ip else NA_real_)
stats_h9 <- dplyr::coalesce(to_num1("H9"),
if (is.finite(stats_ip) && stats_ip > 0) 9 * stats_h / stats_ip else NA_real_)
stats_so9 <- dplyr::coalesce(to_num1("SO9"),
if (is.finite(stats_ip) && stats_ip > 0) 9 * stats_so / stats_ip else NA_real_)
stats_bb9 <- dplyr::coalesce(to_num1("BB9"),
if (is.finite(stats_ip) && stats_ip > 0) 9 * stats_bb / stats_ip else NA_real_)
stats_hr9 <- dplyr::coalesce(to_num1("HR9"),
if (is.finite(stats_ip) && stats_ip > 0) 9 * stats_hr / stats_ip else NA_real_)
}
pitcher_summary <- trackman_summary %>%
mutate(
G = if (nrow(stats_row)) stats_row$G else NA_real_,
GS = if (nrow(stats_row)) stats_row$GS else NA_real_,
W = if (nrow(stats_row)) stats_row$W else NA_real_,
L = if (nrow(stats_row)) stats_row$L else NA_real_,
SV = if (nrow(stats_row)) stats_row$SV else NA_real_,
IP = if (nrow(stats_row) && is.finite(stats_ip)) stats_ip else IP,
ERA = if (nrow(stats_row)) stats_row$ERA else ERA,
WHIP = if (nrow(stats_row) && is.finite(stats_whip)) stats_whip else WHIP,
`H/9` = if (nrow(stats_row) && is.finite(stats_h9)) stats_h9 else `H/9`,
`K/9` = if (nrow(stats_row) && is.finite(stats_so9)) stats_so9 else `K/9`,
`BB/9` = if (nrow(stats_row) && is.finite(stats_bb9)) stats_bb9 else `BB/9`,
`HR/9` = if (nrow(stats_row) && is.finite(stats_hr9)) stats_hr9 else `HR/9`,
`Strike%` = if (nrow(stats_row)) stats_row$strike_pct else `Strike%`,
`CSW%` = if (nrow(stats_row)) stats_row$csw_pct else `CSW%`,
`Chase%` = if (nrow(stats_row)) stats_row$chase_pct else `Chase%`,
`Zone%` = if (nrow(stats_row)) stats_row$zone_pct else `Zone%`,
`Whiff%` = if (nrow(stats_row)) stats_row$whiff_pct else `Whiff%`,
`Z-Whiff%` = if (nrow(stats_row)) stats_row$z_whiff_pct else `Z-Whiff%`,
`Put Away%` = if (nrow(stats_row)) stats_row$put_away_pct else `Put Away%`,
`Barrel%` = if (nrow(stats_row)) stats_row$barrel_pct else `Barrel%`,
xwOBA = if (nrow(stats_row)) stats_row$xwOBA else xwOBA,
Stuff = round(if (nrow(stats_row)) stats_row$stuff else Stuff)
) %>%
select(
G, GS, W, L, SV, IP, ERA, WHIP,
`H/9`, `K/9`, `BB/9`, `HR/9`, `R/9`, BBE,
`Strike%`, `CSW%`, `Chase%`, `Zone%`, `Whiff%`, `Z-Whiff%`,
`Put Away%`, `Barrel%`, xwOBA, Stuff
) %>%
mutate(across(everything(), ~as.numeric(.)))
pitcher_summary %>%
gt() %>%
wvu_gt_theme() %>%
data_color(columns = Stuff, colors = make_color_fn(80, 120)) %>%
data_color(columns = `K/9`, colors = make_color_fn(
quantile( summary_df_pitcher$`K/9`, 0.1, na.rm = TRUE),
quantile( summary_df_pitcher$`K/9`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Strike%`, colors = make_color_fn(50, 70)) %>%
data_color(columns = `CSW%`, colors = make_color_fn(18, 40)) %>%
data_color(columns = `Chase%`, colors = make_color_fn(
quantile( summary_df_pitcher$`Chase%`, 0.1, na.rm = TRUE),
quantile( summary_df_pitcher$`Chase%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Whiff%`, colors = make_color_fn(
quantile( summary_df_pitcher$`Whiff%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Whiff%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Z-Whiff%`, colors = make_color_fn(
quantile(summary_df_pitcher$`Z-Whiff%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Z-Whiff%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Zone%`, colors = make_color_fn(
quantile(summary_df_pitcher$`Zone%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Zone%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Barrel%`, colors = make_color_fn_reverse(
quantile(summary_df_pitcher$`Barrel%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Barrel%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Put Away%`, colors = make_color_fn(
quantile(summary_df_pitcher$`Put Away%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Put Away%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `H/9`, colors = make_color_fn_reverse(
quantile(summary_df_pitcher$`H/9`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`H/9`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `R/9`, colors = make_color_fn_reverse(
quantile(summary_df_pitcher$`R/9`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`R/9`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `HR/9`, colors = make_color_fn_reverse(
quantile(summary_df_pitcher$`HR/9`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`HR/9`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `BB/9`, colors = make_color_fn_reverse(
quantile(summary_df_pitcher$`BB/9`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`BB/9`, 0.9, na.rm = TRUE))) %>%
fmt_number(columns = c(ERA, WHIP), decimals = 2) %>%
fmt_number(columns = c(`K/9`, `BB/9`, `HR/9`, `H/9`, `R/9`), decimals = 1) %>%
fmt_number(columns = c(`Strike%`, `CSW%`, `Chase%`, `Zone%`, `Whiff%`, `Z-Whiff%`, `Put Away%`, `Barrel%`), decimals = 1) %>%
fmt_number(columns = xwOBA, decimals = 3) %>%
fmt_number(columns = Stuff, decimals = 0) %>%
fmt_missing(columns = everything(), missing_text = "-")
}
pitch_summary <- function(data, player, sim = FALSE){
data <- data %>% filter(Pitcher == player)
data <- data %>%
dplyr::group_by(BatterSide) %>%
dplyr::mutate(mean_RelSide = mean(RelSide, na.rm = TRUE)) %>%
dplyr::ungroup() %>%
dplyr::filter((abs(RelSide) - abs(mean_RelSide)) < 0.5)
types <- data %>%
dplyr::group_by(TaggedPitchType) %>%
dplyr::summarise(n = 100 * dplyr::n() / nrow(data), .groups = "drop") %>%
dplyr::filter(n >= 1) %>%
dplyr::pull(TaggedPitchType) %>%
unique()
data <- data %>%
dplyr::mutate(
SpinAxis = SpinAxis + 180,
SpinAxis = ifelse(SpinAxis > 360, SpinAxis - 360, SpinAxis)
)
has_arm_angle <- "arm_angle" %in% names(data)
spin <- data %>%
dplyr::filter(TaggedPitchType %in% types) %>%
dplyr::group_by(TaggedPitchType) %>%
dplyr::summarise(axis = round(stats::median(SpinAxis, na.rm = TRUE), 1), .groups = "drop") %>%
dplyr::rename(`Pitch Type` = TaggedPitchType) %>%
dplyr::mutate(Axis = angle_to_clock(axis))
if (!sim) {
xwobacon_chase <- data %>%
dplyr::filter(TaggedPitchType %in% types) %>%
dplyr::group_by(TaggedPitchType) %>%
dplyr::summarise(
xwOBAcon = sprintf("%.3f", mean(xwOBA[PitchCall == "InPlay"], na.rm = TRUE)),
.groups = "drop"
) %>%
dplyr::rename(`Pitch Type` = TaggedPitchType)
}
pitcher_summary_raw <- data %>%
dplyr::filter(TaggedPitchType %in% types, TaggedPitchType != "Other") %>%
dplyr::group_by(TaggedPitchType) %>%
dplyr::summarise(
Usage = round((dplyr::n() / nrow(data)) * 100, 1),
Velo = sprintf("%.1f", mean(RelSpeed, na.rm = TRUE)),
Spin = sprintf("%.0f", mean(SpinRate, na.rm = TRUE)),
HB = sprintf("%.1f", mean(HorzBreak, na.rm = TRUE)),
iVB = sprintf("%.1f", mean(InducedVertBreak, na.rm = TRUE)),
Vaa = sprintf("%.1f", mean(VertApprAngle, na.rm = TRUE)),
Haa = sprintf("%.1f", mean(HorzApprAngle, na.rm = TRUE)),
Ext = sprintf("%.1f", mean(Extension, na.rm = TRUE)),
RelS = sprintf("%.1f", mean(RelSide, na.rm = TRUE)),
RelH = sprintf("%.1f", mean(RelHeight, na.rm = TRUE)),
`Arm Angle` = if (has_arm_angle) sprintf("%.1f", mean(arm_angle, na.rm = TRUE)) else NA_character_,
`Whiff%` = sprintf("%.1f", 100 * mean(is_whiff, na.rm = TRUE)),
`Z-Whiff%` = sprintf("%.1f", 100 * (mean(in_zone_whiff, na.rm = TRUE))),
`Zone%` = sprintf("%.1f", 100 * mean(in_zone, na.rm = TRUE)),
Stuff = round(mean(stuff, na.rm = TRUE)),
.groups = "drop"
) %>%
dplyr::rename(`Pitch Type` = TaggedPitchType) %>%
dplyr::arrange(dplyr::desc(Usage)) %>%
dplyr::left_join(spin, by = "Pitch Type")
if (!sim) {
pitcher_summary_raw <- pitcher_summary_raw %>%
dplyr::left_join(xwobacon_chase, by = "Pitch Type")
} else {
pitcher_summary_raw <- pitcher_summary_raw %>%
dplyr::mutate(
xwOBAcon = NA_real_
)
}
pitcher_summary_num <- pitcher_summary_raw %>%
dplyr::select(dplyr::any_of(c(
"Pitch Type","Usage","Velo","iVB","HB","Spin","Axis","RelH","RelS",
"Ext","Arm Angle","Haa","Vaa","Whiff%","Z-Whiff%","Chase%","Zone%","xwOBAcon","Stuff"
))) %>%
dplyr::mutate(dplyr::across(-c(`Pitch Type`, Axis), ~ suppressWarnings(as.numeric(.))))
domain_df <- if (exists("summary_df_pitcher")) summary_df_pitcher else pitcher_summary_num
max_usage <- pitcher_summary_num %>%
dplyr::arrange(dplyr::desc(Usage)) %>%
dplyr::slice_head(n = 1) %>%
dplyr::pull(Usage)
tbl <- pitcher_summary_num %>%
gt::gt() %>%
wvu_gt_theme() %>%
gt::fmt_missing(columns = gt::everything(), missing_text = "-") %>%
# always-safe colorings
data_color(columns = Stuff, colors = make_color_fn(80, 120)) %>%
data_color(columns = Usage, colors = make_color_fn(0, max_usage)) %>%
# pitch-type color labels
data_color(
columns = `Pitch Type`,
colors = scales::col_factor(
palette = pitch_colors,
domain = names(pitch_colors),
na.color = "white"
)
)
if ("Arm Angle" %in% names(pitcher_summary_num)) {
tbl <- tbl %>% gt::fmt_number(columns = `Arm Angle`, decimals = 1)
}
if ("Whiff%" %in% names(pitcher_summary_num)) {
tbl <- tbl %>%
data_color(columns = `Whiff%`, colors = make_color_fn(
stats::quantile(domain_df$`Whiff%`, 0.10, na.rm = TRUE),
stats::quantile(domain_df$`Whiff%`, 0.90, na.rm = TRUE)
))
}
if ("Z-Whiff%" %in% names(pitcher_summary_num)) {
tbl <- tbl %>%
data_color(columns = `Z-Whiff%`, colors = make_color_fn(
stats::quantile(domain_df$`Z-Whiff%`, 0.10, na.rm = TRUE),
stats::quantile(domain_df$`Z-Whiff%`, 0.90, na.rm = TRUE)
))
}
if ("Zone%" %in% names(pitcher_summary_num)) {
tbl <- tbl %>%
data_color(columns = `Zone%`, colors = make_color_fn(
stats::quantile(domain_df$`Zone%`, 0.10, na.rm = TRUE),
stats::quantile(domain_df$`Zone%`, 0.90, na.rm = TRUE)
))
}
if ("Chase%" %in% names(pitcher_summary_num)) {
tbl <- tbl %>%
data_color(columns = `Chase%`, colors = make_color_fn(
stats::quantile(domain_df$`Chase%`, 0.10, na.rm = TRUE),
stats::quantile(domain_df$`Chase%`, 0.90, na.rm = TRUE)
))
}
if ("xwOBAcon" %in% names(pitcher_summary_num)) {
tbl <- tbl %>%
data_color(columns = xwOBAcon, colors = make_color_fn_reverse(
stats::quantile(domain_df$xwOBAcon, 0.10, na.rm = TRUE),
stats::quantile(domain_df$xwOBAcon, 0.90, na.rm = TRUE)
))
}
tbl
}
pitch_summary_side <- function(data, player, bat_side){
data <- data %>%
filter(Pitcher == player, BatterSide == bat_side, TaggedPitchType != "Other", !is.na(TaggedPitchType))
types <- data %>%
group_by(TaggedPitchType) %>%
summarise(n = 100 * n() / nrow(data)) %>%
filter(n >= 1)
types <- unique(types$TaggedPitchType)
data <- data %>%
mutate(SpinAxis = SpinAxis + 180) %>%
mutate(SpinAxis = ifelse(SpinAxis > 360, SpinAxis - 360, SpinAxis))
spin <- data %>%
filter(TaggedPitchType %in% types) %>%
group_by(TaggedPitchType) %>%
summarise(axis = round(median(SpinAxis, na.rm = TRUE), 1)) %>%
rename(`Pitch Type` = TaggedPitchType) %>%
mutate(axis = angle_to_clock(axis))
pitcher_summary <- data %>%
filter(TaggedPitchType %in% types) %>%
group_by(TaggedPitchType) %>%
summarise(
Usage = round((n() / nrow(data)) * 100, 1),
`CSW%` = sprintf("%.1f", 100 * mean(is_csw, na.rm = TRUE)),
`Chase%` = sprintf("%.1f", 100 * mean(chase, na.rm = TRUE)),
`Zone%` = sprintf("%.1f", 100 * mean(in_zone, na.rm = TRUE)),
`Strike%` = sprintf("%.1f", 100 * sum(!PitchCall %in% c("BallCalled", "HitByPitch", "BallinDirt", "BallIntentional", "Undefined")) / n()),
`Whiff%` = sprintf("%.1f", 100 * mean(is_whiff, na.rm = TRUE)),
`Z-Whiff%` = sprintf("%.1f", 100 * mean(in_zone_whiff, na.rm = TRUE)),
`Put Away%` = sprintf("%.1f", 100 * mean(is_put_away, na.rm = TRUE)),
`Avg EV` = sprintf("%.1f", mean(ExitSpeed, na.rm = TRUE)),
`GB%` = sprintf("%.1f", 100 * (sum((AutoHitType == "GroundBall" & PitchCall == "InPlay"), na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Hard-Hit%` = sprintf("%.1f", 100 * mean(is_hard_hit, na.rm = TRUE)),
`Barrel%` = sprintf("%.1f", 100 * mean(is_barrel, na.rm = TRUE)),
xwOBAcon = sprintf("%.3f", mean(xwOBA[PitchCall == "InPlay"], na.rm = TRUE)),
xwOBA = sprintf("%.3f", mean(xwOBA, na.rm = TRUE))
) %>%
rename(`Pitch Type` = TaggedPitchType) %>%
arrange(desc(Usage))
pitcher_summary <- pitcher_summary %>%
left_join(spin, by = "Pitch Type")
pitcher_summary <- pitcher_summary %>%
select(`Pitch Type`, Usage, `CSW%`, `Chase%`, `Zone%`,`Strike%`, `Whiff%`, `Z-Whiff%`, `Put Away%`, `Avg EV`, `GB%`, `Hard-Hit%`, `Barrel%`, xwOBA, xwOBAcon)
max_usage <- pitcher_summary %>%
arrange(-Usage) %>%
slice_head(n = 1) %>%
pull(Usage)
pitcher_summary <- pitcher_summary %>%
mutate(across(-`Pitch Type`, as.numeric)) %>%
gt() %>%
wvu_gt_theme(title = paste0("Vs ", bat_side)) %>%
data_color(
columns = `Pitch Type`,
colors = scales::col_factor(
palette = pitch_colors,
domain = names(pitch_colors),
na.color = "white"
)
) %>%
data_color(columns = `Chase%`, colors = make_color_fn(
quantile(summary_df_pitcher$`Chase%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Chase%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Whiff%`, colors = make_color_fn(
quantile(summary_df_pitcher$`Whiff%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Whiff%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Z-Whiff%`, colors = make_color_fn(
quantile(summary_df_pitcher$`Z-Whiff%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Z-Whiff%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Zone%`, colors = make_color_fn(
quantile(summary_df_pitcher$`Zone%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Zone%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `CSW%`, colors = make_color_fn(
quantile(summary_df_pitcher$`CSW%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`CSW%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Strike%`, colors = make_color_fn(
quantile(summary_df_pitcher$`Strike%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Strike%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `GB%`, colors = make_color_fn(
quantile(summary_df_pitcher$`GB%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`GB%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Barrel%`, colors = make_color_fn_reverse(
quantile(summary_df_pitcher$`Barrel%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Barrel%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Put Away%`, colors = make_color_fn(
quantile(summary_df_pitcher$`Put Away%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Put Away%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = xwOBAcon, colors = make_color_fn_reverse(
quantile(summary_df_pitcher$xwOBAcon, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$xwOBAcon, 0.9, na.rm = TRUE))) %>%
data_color(columns = xwOBA, colors = make_color_fn_reverse(
quantile(summary_df_pitcher$xwOBA, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$xwOBA, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Avg EV`, colors = make_color_fn_reverse(
quantile(summary_df_pitcher$`Avg EV`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Avg EV`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Hard-Hit%`, colors = make_color_fn_reverse(
quantile(summary_df_pitcher$`Hard-Hit%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Hard-Hit%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = Usage, colors = make_color_fn(0, max_usage)) %>%
fmt_missing(columns = everything(), missing_text = "-")
pitcher_summary
}
release_points <- function(data, player){
data <- data %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
group_by(BatterSide) %>%
mutate(mean_RelSide = mean(RelSide, na.rm = TRUE)) %>%
ungroup() %>%
filter((abs(RelSide) - abs(mean_RelSide)) < .5)
data %>%
ggplot(aes(RelSide, RelHeight)) +
geom_point(aes(fill = TaggedPitchType), size = 5, shape = 21, color = "black", stroke = .25, alpha = .7) +
xlim(-5, 5) + ylim(0, 8) +
annotate("text", x = -5, y = 8,
label = "← 1B", color = "black", size = 3, hjust = 0.5) +
annotate("text", x = 5, y = 8,
label = "3B →", color = "black", size = 3, hjust = 0.5) +
theme_minimal() +
xlab("Horizontal Release (ft)") + ylab("Vertical Release (ft)") +
labs(fill = " ") +
ggtitle("Release Points") +
theme(
plot.title = element_text(size = 12, hjust = .5),
axis.text.x = element_text(size = 12),
axis.text.y = element_text(size = 12),
axis.title.x = element_text(size = 12),
axis.title.y = element_text(size = 12),
legend.position = "none",
panel.background = element_rect(fill = "#ffffff"),
legend.title = element_blank()) +
geom_rect(aes(xmin = -5, xmax = 5, ymin = 0, ymax = .83), fill = "#632b11", size = 1) +
geom_rect(aes(xmin = -0.5, xmax = 0.5, ymin = 0.8, ymax = .95),
fill = "white", color = "black", size = .5) +
scale_fill_manual(values = pitch_colors)
}
velo <- function(data, player) {
types <- data %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
group_by(TaggedPitchType) %>%
summarise(n = 100 * n() / nrow(data %>% filter(Pitcher == player))) %>%
filter(n >= 1) %>%
arrange(desc(n))
types <- unique(types$TaggedPitchType)
data_filtered <- data %>%
filter(Pitcher == player & TaggedPitchType %in% types) %>%
rename(`Pitch Type` = TaggedPitchType)
pitch_order <- data_filtered %>%
group_by(`Pitch Type`) %>%
summarize(avg_speed = mean(RelSpeed, na.rm = TRUE), .groups = "drop") %>%
arrange(avg_speed) %>%
pull(`Pitch Type`)
data_filtered <- data_filtered %>%
mutate(`Pitch Type` = factor(`Pitch Type`, levels = pitch_order))
avg_speed <- data_filtered %>%
group_by(`Pitch Type`) %>%
summarize(
avg_speed = mean(RelSpeed, na.rm = TRUE),
usage_pct = n() / nrow(data_filtered) * 100,
.groups = "drop"
)
min_velo <- min(data_filtered$RelSpeed, na.rm = TRUE)
max_velo <- max(data_filtered$RelSpeed, na.rm = TRUE)
data_filtered %>%
ggplot(aes(x = RelSpeed, fill = `Pitch Type`)) +
geom_density(alpha = 0.6) +
geom_point(data = avg_speed, aes(x = avg_speed, y = 0.01, color = `Pitch Type`), size = 3, shape = 21, stroke = 0.3) +
geom_segment(data = avg_speed, aes(x = avg_speed, xend = avg_speed, y = 0, yend = Inf, color = `Pitch Type`), linetype = "dashed") +
facet_grid(`Pitch Type` ~ ., scales = "free_y", switch = "y") +
theme_minimal() +
xlim(min_velo, max_velo) +
xlab("Velocity (MPH)") +
ggtitle("Velocities") +
theme(
plot.title = element_text(size = 12, hjust = .5),
legend.position = "none",
strip.text.y = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
strip.background = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor.y = element_blank(),
legend.title = element_blank(),
axis.text.x = element_text(size = 12),
axis.title.y = element_blank(),
axis.title.x = element_text(size = 12),
panel.background = element_rect(fill = "#ffffff")
) +
scale_fill_manual(values = pitch_colors) +
scale_color_manual(values = pitch_colors)
}
hitter_game = function(data, hitter, input_game, batter_ids = NULL){
data <- filter_rows_by_selection(
data,
"Batter",
hitter,
batter_ids,
id_col = "BatterId",
team_cols = c("BatterTeam")
) %>%
drop_na(BatterTeam)
data %>%
mutate(
game_key = if_else(
!is.na(GameID) & GameID != "",
as.character(GameID),
paste(Date, PitcherTeam, sep = "__")
)
) %>%
filter(game_key == input_game) %>%
arrange(Inning, PAofInning, PitchofPA) %>%
group_by(Inning, PAofInning) %>%
mutate(PA_id = cur_group_id()) %>%
ungroup() %>%
mutate(last_pitch_of_pa = ifelse(lead(PA_id) != PA_id | is.na(lead(PA_id)), 1, 0),
ExitSpeed = ifelse(PitchCall == "InPlay", ExitSpeed, NA),
Angle = ifelse(PitchCall == "InPlay", Angle, NA),
`Pull?` = if_else((BatterSide == "Right" & Bearing < -15) |
(BatterSide == "Left" & Bearing > 15), "Yes", "No"),
`Pull?` = ifelse(PitchCall == "InPlay", `Pull?`, NA)) %>%
drop_na(event_type) %>%
select(PA_id, Pitcher, PitcherThrows, BatterSide, Balls, Strikes, TaggedPitchType, RelSpeed,in_zone,
event_type, ExitSpeed, Angle, `Pull?`) %>%
mutate(ExitSpeed = round(ExitSpeed),
Angle = round(Angle),
RelSpeed = round(RelSpeed, 1),
in_zone = ifelse(in_zone == 1, "Yes", "No"),
PitcherThrows = ifelse(PitcherThrows == "Right", "R", "L"),
BatterSide = ifelse(BatterSide == "Right", "R", "L")) %>%
rename(`PA #` = PA_id,
`Pitch Type` = TaggedPitchType,
velo = RelSpeed,
`In Zone?` = in_zone,
event = event_type,
EV = ExitSpeed,
LA = Angle,
Throws = PitcherThrows,
hits = BatterSide) %>%
gt() %>%
wvu_gt_theme(title = paste0(hitter, " - ", input_game)) %>%
data_color(
columns = EV,
colors = scales::col_numeric(
palette = c("#ffcccc", "white", "lightgreen"),
domain = c(50, 120),
na.color = "white"
)
) %>%
data_color(
columns = `PA #`,
colors = scales::col_factor(
palette = pa_colors,
domain = names(pa_colors),
na.color = "white"
)
) %>%
tab_style(
style = cell_fill(color = "lightgreen"),
locations = cells_body(columns = `In Zone?`, rows = `In Zone?` == "Yes")
) %>%
tab_style(
style = cell_fill(color = "#ffcccc"),
locations = cells_body(columns = `In Zone?`, rows = `In Zone?` == "No")
) %>%
tab_style(
style = cell_fill(color = "lightgreen"),
locations = cells_body(columns = LA, rows = LA >= 8 | LA <= 32)
) %>%
tab_style(
style = cell_fill(color = "#ffcccc"),
locations = cells_body(columns = LA, rows = LA < 8 | LA > 32)
) %>%
fmt_missing(columns = everything(), missing_text = "-")
}
assign_zones <- function(row) {
plate_x <- row['PlateLocSide']
plate_z <- row['PlateLocHeight']
if (is.na(plate_x) || is.na(plate_z)) {
return('NA')
}
if (-8.5 < plate_x & plate_x < -17/6 & 34 < plate_z & plate_z < 42) {
return('1')
} else if (-17/6 < plate_x & plate_x < 17/6 & 34 < plate_z & plate_z < 42) {
return('2')
} else if (17/6 < plate_x & plate_x < 8.5 & 34 < plate_z & plate_z < 42) {
return('3')
} else if (-8.5 < plate_x & plate_x < -17/6 & 26 < plate_z & plate_z < 34) {
return('4')
} else if (-17/6 < plate_x & plate_x < 17/6 & 26 < plate_z & plate_z < 34) {
return('5')
} else if (17/6 < plate_x & plate_x < 8.5 & 26 < plate_z & plate_z < 34) {
return('6')
} else if (-8.5 < plate_x & plate_x < -17/6 & 18 < plate_z & plate_z < 26) {
return('7')
} else if (-17/6 < plate_x & plate_x < 17/6 & 18 < plate_z & plate_z < 26) {
return('8')
} else if (17/6 < plate_x & plate_x < 8.5 & 18 < plate_z & plate_z < 26) {
return('9')
} else if (-13.33 < plate_x & plate_x < -8.5 & 30 < plate_z & plate_z < 48) {
return('10')
} else if (-13.33 < plate_x & plate_x < 0 & 42 < plate_z & plate_z < 46) {
return('10')
} else if (8.5 < plate_x & plate_x < 13.33 & 30 < plate_z & plate_z < 46) {
return('11')
} else if (0 < plate_x & plate_x < 13.33 & 42 < plate_z & plate_z < 46) {
return('11')
} else if (-13.33 < plate_x & plate_x < -8.5 & 12 < plate_z & plate_z < 30) {
return('12')
} else if (-13.33 < plate_x & plate_x < 0 & 12 < plate_z & plate_z < 18) {
return('12')
} else if (8.5 < plate_x & plate_x < 13.33 & 12 < plate_z & plate_z < 30) {
return('13')
} else if (0 < plate_x & plate_x < 13.33 & 12 < plate_z & plate_z < 18) {
return('13')
} else {
return('20')
}
}
ev_map <- function(data, batter, stat) {
name_conversion <- list(
`Avg EV` = "ExitSpeed",
wOBAcon = "wobacon",
xwOBAcon = "xwOBA",
`Contact %` = "is_whiff",
`Hard Hit %` = "is_hard_hit",
`Swing Decision Runs Gained / 100` = "sd_rv_added",
`Correct Swing Decision %` = "correct_decision"
)
stat_name <- name_conversion[[stat]]
stat_sym <- rlang::sym(stat_name)
data <- data %>%
filter(Batter == batter) %>%
drop_na({{ stat_name }}) %>%
mutate(is_whiff = 1 - is_whiff)
if (stat_name %in% c("ExitSpeed", "wobacon", "xwOBA", "is_hard_hit")){
data <- data %>%
filter(PitchCall == "InPlay")
}
bat_side <- data %>%
count(BatterSide, sort = TRUE) %>%
slice_head(n = 1) %>%
pull(BatterSide)
if (nrow(data) == 0) {
print("No data available for the specified criteria.")
return()
}
data <- data %>%
filter(!is.na(PlateLocSide) & !is.na(PlateLocHeight)) %>%
mutate(zone = sapply(1:n(), function(i) assign_zones(data[i, ]))) %>%
group_by(zone) %>%
summarize(mean_stat = mean(!!stat_sym, na.rm = TRUE), .groups = "drop") %>%
mutate(
zone = as.character(zone),
mean_stat = if (stat_name %in% c("sd_rv_added"))
mean_stat * 100 else mean_stat
)
zone_coordinates <- list(
`1` = list(x = c(-8.5, -17/6, -17/6, -8.5), y = c(34, 34, 42, 42)),
`2` = list(x = c(-17/6, -17/6, 17/6, 17/6), y = c(34, 42, 42, 34)),
`3` = list(x = c(17/6, 17/6, 8.5, 8.5), y = c(34, 42, 42, 34)),
`4` = list(x = c(-8.5, -17/6, -17/6, -8.5), y = c(26, 26, 34, 34)),
`5` = list(x = c(-17/6, -17/6, 17/6, 17/6), y = c(26, 34, 34, 26)),
`6` = list(x = c(17/6, 17/6, 8.5, 8.5), y = c(26, 34, 34, 26)),
`7` = list(x = c(-8.5, -17/6, -17/6, -8.5), y = c(18, 18, 26, 26)),
`8` = list(x = c(-17/6, -17/6, 17/6, 17/6), y = c(18, 26, 26, 18)),
`9` = list(x = c(17/6, 17/6, 8.5, 8.5), y = c(18, 26, 26, 18)),
`10` = list(x = c(-13.33, -13.33, 0, 0, -8.5, -8.5, -13.33),
y = c(30, 48, 48, 42, 42, 30, 30)),
`11` = list(x = c(13.33, 13.33, 0, 0, 8.5, 8.5, 13.33),
y = c(30, 48, 48, 42, 42, 30, 30)),
`12` = list(x = c(-13.33, -13.33, 0, 0, -8.5, -8.5, -13.33),
y = c(30, 12, 12, 18, 18, 30, 30)),
`13` = list(x = c(13.33, 13.33, 0, 0, 8.5, 8.5, 13.33),
y = c(30, 12, 12, 18, 18, 30, 30))
)
zone_coordinates_df <- lapply(names(zone_coordinates), function(z) {
data.frame(
zone = as.character(z),
x = zone_coordinates[[z]]$x,
y = zone_coordinates[[z]]$y
)
}) %>%
bind_rows()
zone_df <- zone_coordinates_df %>%
left_join(data, by = "zone")
zone_labels <- zone_df %>%
filter(zone %in% as.character(1:9)) %>%
group_by(zone) %>%
summarize(
x = mean(x, na.rm = TRUE),
y = mean(y, na.rm = TRUE),
label = case_when(
stat_name %in% c("is_whiff", "is_hard_hit", "correct_decision") ~ sprintf("%.1f%%",
mean(mean_stat, na.rm = TRUE)
* 100),
stat_name %in% c("wobacon", "xwOBA") ~ sprintf("%.3f", mean(mean_stat, na.rm = TRUE)),
stat_name %in% c("sd_rv_added") ~
sprintf("%.1f", mean(mean_stat, na.rm = TRUE)),
TRUE ~ as.character(round(mean(mean_stat, na.rm = TRUE), 1))
),
.groups = "drop"
) %>%
filter(!is.na(label))
gg <- ggplot(zone_df, aes(x = -x, y = y, group = zone, fill = mean_stat)) +
geom_polygon(color = "white") +
geom_rect(
xmin = -8.5, xmax = -8.5, ymin = 0, ymax = 5,
color = "black", alpha = 1
) +
geom_rect(
xmin = 8.5, xmax = 8.5, ymin = 0, ymax = 5,
color = "black", alpha = 1
) +
geom_rect(
xmin = -8.5, xmax = 8.5, ymin = 5, ymax = 5,
color = "black", alpha = 1
) +
geom_segment(aes(x = 0, y = -4, xend = 8.5, yend = 0), color = "black") +
geom_segment(aes(x = 0, y = -4, xend = -8.5, yend = 0), color = "black") +
geom_text(data = zone_labels, aes(x = -x, y = y, label = label),
inherit.aes = FALSE, size = 4.5, color = "white") +
xlim(-25, 25) +
ylim(-5, 50) +
theme_void() +
theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())
if (stat_name == "ExitSpeed") {
gg <- gg + scale_fill_gradientn(
colors = c("#002855", "lightgrey", "#EAAA00"),
values = scales::rescale(c(75, 90, 105)),
limits = c(75, 105),
oob = scales::squish,
breaks = seq(75, 105, by = 10),
guide = guide_colorbar(barwidth = 1, barheight = 25)
)
} else if (stat_name == "wobacon"){
gg <- gg + scale_fill_gradientn(
colors = c("#002855", "lightgrey", "#EAAA00"),
values = scales::rescale(c(0.250, .400, .550)),
limits = c(.250, .550),
oob = scales::squish,
breaks = seq(.250, .550, by = .050),
guide = guide_colorbar(barwidth = 1, barheight = 25)
)
}else if (stat_name == "xwOBA"){
gg <- gg + scale_fill_gradientn(
colors = c("#002855", "lightgrey", "#EAAA00"),
values = scales::rescale(c(0.250, .400, .550)),
limits = c(.250, .550),
oob = scales::squish,
breaks = seq(.250, .550, by = .050),
guide = guide_colorbar(barwidth = 1, barheight = 25)
)
} else if (stat_name == "is_hard_hit"){
gg <- gg + scale_fill_gradientn(
colors = c("#002855", "lightgrey", "#EAAA00"),
values = scales::rescale(c(0.150, .350, .550)),
limits = c(.150, .550),
oob = scales::squish,
breaks = seq(.150, .550, by = .050),
labels = scales::label_percent(accuracy = 1),
guide = guide_colorbar(barwidth = 1, barheight = 25)
)
} else if (stat_name == "is_whiff"){
gg <- gg + scale_fill_gradientn(
colors = c("#002855", "lightgrey", "#EAAA00"),
values = scales::rescale(c(0.750, .850, .950)),
limits = c(.750, .950),
oob = scales::squish,
breaks = seq(.750, .950, by = .050),
labels = scales::label_percent(accuracy = 1),
guide = guide_colorbar(barwidth = 1, barheight = 25)
)
}else if (stat_name == "sd_rv_added"){
gg <- gg + scale_fill_gradientn(
colors = c("#002855", "lightgrey", "#EAAA00"),
values = scales::rescale(c(-3, 0, 3)),
limits = c(-3, 3),
oob = scales::squish,
breaks = seq(-3, 3, by = 1),
guide = guide_colorbar(barwidth = 1, barheight = 25)
)
} else if (stat_name == "correct_decision"){
gg <- gg + scale_fill_gradientn(
colors = c("#002855", "lightgrey", "#EAAA00"),
values = scales::rescale(c(.600, .700, .800)),
limits = c(.600, .800),
oob = scales::squish,
breaks = seq(.600, .900, by = .050),
labels = scales::label_percent(accuracy = 1),
guide = guide_colorbar(barwidth = 1, barheight = 25)
)
}
gg <- gg +
coord_equal() +
theme(
strip.text.y = element_blank(),
plot.title = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
strip.background = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor.y = element_blank(),
axis.text.x = element_blank(),
axis.title.y = element_blank(),
axis.title.x = element_blank(),
legend.title = element_blank(),
legend.text = element_text(size = 10),
legend.position = "left",
legend.key.size = unit(2, "lines")
)
if (bat_side == "Right") {
gg <- gg + annotate("text", x = -18, y = 30, label = "R", color = "#002855", size = 6, fontface = "bold")
}
if (bat_side == "Left") {
gg <- gg + annotate("text", x = 18, y = 30, label = "L", color = "#002855", size = 6, fontface = "bold")
}
gg
}
zone_map <- function(data, batter, type) {
data <- data %>%
mutate(
zone_group = case_when(
between(PlateLocSide, -6, 6) & between(PlateLocHeight, 22, 38) ~ "Heart",
between(PlateLocSide, -13, 13) & between(PlateLocHeight, 14, 46) ~ "Shadow",
between(PlateLocSide, -18, 18) & between(PlateLocHeight, 10, 50) ~ "Chase",
TRUE ~ "Waste"
),
correct_swing = case_when(
in_zone == 1 & is_swing == 1 ~ 1,
in_zone == 0 & is_swing == 1 ~ 0,
in_zone == 0 & is_swing == 0 ~ 1,
in_zone == 1 & is_swing == 0 ~ 0
)
)
if (type != "All") {
data <- data %>% filter(TaggedPitchType == type)
}
league_avg_swing <- league_avg %>%
filter(TaggedPitchType == type)
batter_avg <- data %>%
filter(Batter == batter) %>%
group_by(zone_group) %>%
summarise(batter_swing = mean(is_swing, na.rm = TRUE), .groups = "drop")
zone_swing <- full_join(league_avg_swing, batter_avg, by = "zone_group") %>%
mutate(delta_swing = batter_swing - league_swing)
shadow_cs <- data %>%
filter(zone_group == "Shadow", Batter == batter) %>%
summarise(cs = mean(correct_decision, na.rm = TRUE)) %>%
pull(cs)
zones_df <- tribble(
~zone_group, ~xmin, ~xmax, ~ymin, ~ymax, ~label_x, ~label_y,
"Waste", -25, 25, 0, 60, 0, 55,
"Chase", -18, 18, 10, 50, 0, 48,
"Shadow", -13, 13, 14, 46, 0, 44,
"Heart", -6, 6, 22, 38, 0, 30
) %>%
left_join(zone_swing, by = "zone_group")
ggplot(zones_df) +
geom_rect(aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, fill = delta_swing), color = "white") +
geom_text(aes(x = label_x, y = label_y, label = paste0(scales::percent(batter_swing, accuracy = 0.1))), size = 5, color = "white") +
geom_text(aes(x = 0, y = 16, label = paste0("Shadow Zone Correct Swing % - ", scales::percent(shadow_cs, accuracy = 0.1))), size = 4, color = "white") +
scale_fill_gradient2(
low = "#002855", mid = "lightgrey", high = "#EAAA00",
midpoint = 0, limits = c(-0.2, 0.2), oob = scales::squish,
name = "Swing % over P4 Average",
labels = scales::label_percent(accuracy = 1),
guide = guide_colorbar(barwidth = 1, barheight = 25)
) +
geom_rect(
xmin = -8.5,
xmax = 8.5,
ymin = 18,
ymax = 42,
fill = NA,
color = "black",
linetype = "dashed"
) +
coord_fixed() +
theme_void() +
theme(
strip.text.y = element_blank(),
plot.title = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
strip.background = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor.y = element_blank(),
axis.text.x = element_blank(),
axis.title.y = element_blank(),
axis.title.x = element_blank(),
legend.text = element_text(size = 10),
legend.position = "right",
legend.key.size = unit(2, "lines")
)
}
hitter_table <- function(data){
data %>%
group_by(Batter) %>%
summarise(
xwOBAcon = mean(xwOBA[PitchCall == "InPlay"], na.rm = TRUE),
xwOBA = mean(xwOBA, na.rm = TRUE),
PA = sum(is_plate_appearance, na.rm = TRUE),
`Batted Balls` = sum(PitchCall == "InPlay", na.rm = TRUE),
Barrels = sum(is_barrel, na.rm = TRUE),
`Barrels/PA` = 100 * (Barrels / PA),
xBA = mean(xba, na.rm = TRUE),
xSLG = mean(xslg, na.rm = TRUE),
Avg = mean(is_hit, na.rm = TRUE),
OBP = mean(on_base, na.rm = TRUE),
SLG = mean(slg, na.rm = TRUE),
`Avg EV` = mean(ExitSpeed, na.rm = TRUE),
`EV90` = quantile(ExitSpeed, .9, na.rm = TRUE),
`Max EV` = max(ExitSpeed[PitchCall == "InPlay"], na.rm = TRUE),
`Barrel%` = 100 * mean(is_barrel, na.rm = TRUE),
`Hard-Hit%` = 100 * mean(is_hard_hit, na.rm = TRUE),
`SwSpot%` = 100 * sum(PitchCall == "InPlay" & Angle >= 8 & Angle <= 32, na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Pull Air%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) &
AutoHitType %in% c("FlyBall", "LineDrive", "Popup") &
PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`HR/FB%` = 100 * sum(AutoHitType == "FlyBall" & PlayResult == "Homerun" & PitchCall == "InPlay", na.rm = TRUE) /
sum(AutoHitType == "FlyBall" & PitchCall == "InPlay", na.rm = TRUE),
`Chase%` = 100 * mean(chase, na.rm = TRUE),
Decisions = 100 * mean(sd_rv_added, na.rm = TRUE),
`Whiff%` = 100 * mean(is_whiff, na.rm = TRUE),
`Z-Con%` = 100 * (1 - mean(in_zone_whiff, na.rm = TRUE)),
`K%` = 100 * mean(is_k, na.rm = TRUE),
`BB%` = 100 * mean(is_walk, na.rm = TRUE),
`Z-Swing%` = 100 * mean(is_swing[in_zone == 1], na.rm = TRUE),
`FPSwing%` = 100 * mean(is_swing[Balls == 0 & Strikes == 0], na.rm = TRUE),
`Swing%` = 100 * mean(is_swing, na.rm = TRUE),
`O-Con%` = 100 * (1 - mean(is_whiff[in_zone == 0], na.rm = TRUE)),
`GB%` = 100 * sum(AutoHitType == "GroundBall" & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`LD%` = 100 * sum(AutoHitType == "LineDrive" & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`FB%` = 100 * sum(AutoHitType == "FlyBall" & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`PU%` = 100 * sum(AutoHitType == "Popup" & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Pull%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) & PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Straight%` = 100 * sum(Bearing >= -15 & Bearing <= 15 & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Oppo%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) & PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Pull GB%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) &
!AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Straight GB%` = 100 * sum(Bearing >= -15 & Bearing <= 15 &
!AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Oppo GB%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) &
!AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Straight Air%` = 100 * sum(Bearing >= -15 & Bearing <= 15 &
AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Oppo Air%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) &
AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
.groups = "drop"
) %>%
mutate(across(-Batter, as.numeric)) %>%
mutate(
across(where(is.numeric),
~ case_when(
grepl("%$", cur_column()) ~ round(.x, 1),
cur_column() %in% c("xwOBAcon", "xwOBA", "xBA", "xSLG", "Avg" ,"OBP", "SLG") ~ round(.x, 3),
cur_column() %in% c("Barrels/PA", "Avg EV", "EV90", "Max EV", "Decisions" ,"OBP", "SLG") ~ round(.x, 1),
TRUE ~ .x
)
)
)
}
hitter_table_by_hand <- function(data){
data %>%
mutate(category = case_when(
TaggedPitchType %in% c("Fastball", "Cutter", "Sinker") ~ "FA",
TaggedPitchType %in% c("Slider", "Sweeper", "Curveball") ~ "BR",
TRUE ~ "OF")) %>%
drop_na(category) %>%
group_by(Batter, category) %>%
summarise(
xwOBAcon = mean(xwOBA[PitchCall == "InPlay"], na.rm = TRUE),
xwOBA = mean(xwOBA, na.rm = TRUE),
PA = sum(is_plate_appearance, na.rm = TRUE),
`Batted Balls` = sum(PitchCall == "InPlay", na.rm = TRUE),
Barrels = sum(is_barrel, na.rm = TRUE),
`Barrels/PA` = 100 * (Barrels / PA),
xBA = mean(xba, na.rm = TRUE),
xSLG = mean(xslg, na.rm = TRUE),
Avg = mean(is_hit, na.rm = TRUE),
OBP = mean(on_base, na.rm = TRUE),
SLG = mean(slg, na.rm = TRUE),
`Avg EV` = mean(ExitSpeed, na.rm = TRUE),
`EV90` = quantile(ExitSpeed, .9, na.rm = TRUE),
`Max EV` = max(ExitSpeed[PitchCall == "InPlay"], na.rm = TRUE),
`Barrel%` = 100 * mean(is_barrel, na.rm = TRUE),
`Hard-Hit%` = 100 * mean(is_hard_hit, na.rm = TRUE),
`SwSpot%` = 100 * sum(PitchCall == "InPlay" & Angle >= 8 & Angle <= 32, na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Pull Air%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) &
AutoHitType %in% c("FlyBall", "LineDrive", "Popup") &
PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`HR/FB%` = 100 * sum(AutoHitType == "FlyBall" & PlayResult == "Homerun" & PitchCall == "InPlay", na.rm = TRUE) /
sum(AutoHitType == "FlyBall" & PitchCall == "InPlay", na.rm = TRUE),
`Chase%` = 100 * mean(chase, na.rm = TRUE),
Decisions = 100 * mean(sd_rv_added, na.rm = TRUE),
`Whiff%` = 100 * mean(is_whiff, na.rm = TRUE),
`Z-Con%` = 100 * (1 - mean(in_zone_whiff, na.rm = TRUE)),
`K%` = 100 * mean(is_k, na.rm = TRUE),
`BB%` = 100 * mean(is_walk, na.rm = TRUE),
`Z-Swing%` = 100 * mean(is_swing[in_zone == 1], na.rm = TRUE),
`FPSwing%` = 100 * mean(is_swing[Balls == 0 & Strikes == 0], na.rm = TRUE),
`Swing%` = 100 * mean(is_swing, na.rm = TRUE),
`O-Con%` = 100 * (1 - mean(is_whiff[in_zone == 0], na.rm = TRUE)),
`GB%` = 100 * sum(AutoHitType == "GroundBall" & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`LD%` = 100 * sum(AutoHitType == "LineDrive" & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`FB%` = 100 * sum(AutoHitType == "FlyBall" & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`PU%` = 100 * sum(AutoHitType == "Popup" & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Pull%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) & PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Straight%` = 100 * sum(Bearing >= -15 & Bearing <= 15 & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Oppo%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) & PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Pull GB%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) &
!AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Straight GB%` = 100 * sum(Bearing >= -15 & Bearing <= 15 &
!AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Oppo GB%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) &
!AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Straight Air%` = 100 * sum(Bearing >= -15 & Bearing <= 15 &
AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Oppo Air%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) &
AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
.groups = "drop"
) %>%
mutate(across(-c(Batter, category), as.numeric)) %>%
mutate(
across(where(is.numeric),
~ case_when(
grepl("%$", cur_column()) ~ round(.x, 1),
cur_column() %in% c("xwOBAcon", "xwOBA", "xBA", "xSLG", "Avg" ,"OBP", "SLG") ~ round(.x, 3),
cur_column() %in% c("Barrels/PA", "Avg EV", "EV90", "Max EV", "Decisions" ,"OBP", "SLG") ~ round(.x, 1),
TRUE ~ .x
)
)
)
}
hitter_table_filter <- function(df){
df <- df %>%
filter(!is.na(TaggedPitchType)) %>%
drop_na(ax0, az0, RelSide,
RelHeight, Extension, RelSpeed)
df %>%
group_by(Batter) %>%
summarise(
xwOBAcon = mean(xwOBA[PitchCall == "InPlay"], na.rm = TRUE),
xwOBA = mean(xwOBA, na.rm = TRUE),
PA = sum(is_plate_appearance, na.rm = TRUE),
`Batted Balls` = sum(PitchCall == "InPlay", na.rm = TRUE),
Barrels = sum(is_barrel, na.rm = TRUE),
`Barrels/PA` = 100 * (Barrels / PA),
xBA = mean(xba, na.rm = TRUE),
xSLG = mean(xslg, na.rm = TRUE),
Avg = mean(is_hit, na.rm = TRUE),
OBP = mean(on_base, na.rm = TRUE),
SLG = mean(slg, na.rm = TRUE),
`Avg EV` = mean(ExitSpeed, na.rm = TRUE),
`EV90` = quantile(ExitSpeed, .9, na.rm = TRUE),
`Max EV` = max(ExitSpeed[PitchCall == "InPlay"], na.rm = TRUE),
`Barrel%` = 100 * mean(is_barrel, na.rm = TRUE),
`Hard-Hit%` = 100 * mean(is_hard_hit, na.rm = TRUE),
`SwSpot%` = 100 * sum(PitchCall == "InPlay" & Angle >= 8 & Angle <= 32, na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Pull Air%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) &
AutoHitType %in% c("FlyBall", "LineDrive", "Popup") &
PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`HR/FB%` = 100 * sum(AutoHitType == "FlyBall" & PlayResult == "Homerun" & PitchCall == "InPlay", na.rm = TRUE) /
sum(AutoHitType == "FlyBall" & PitchCall == "InPlay", na.rm = TRUE),
`Chase%` = 100 * mean(chase, na.rm = TRUE),
Decisions = 100 * mean(sd_rv_added, na.rm = TRUE),
`Whiff%` = 100 * mean(is_whiff, na.rm = TRUE),
`Z-Con%` = 100 * (1 - mean(in_zone_whiff, na.rm = TRUE)),
`K%` = 100 * mean(is_k, na.rm = TRUE),
`BB%` = 100 * mean(is_walk, na.rm = TRUE),
`Z-Swing%` = 100 * mean(is_swing[in_zone == 1], na.rm = TRUE),
`FPSwing%` = 100 * mean(is_swing[Balls == 0 & Strikes == 0], na.rm = TRUE),
`Swing%` = 100 * mean(is_swing, na.rm = TRUE),
`O-Con%` = 100 * (1 - mean(is_whiff[in_zone == 0], na.rm = TRUE)),
`GB%` = 100 * sum(AutoHitType == "GroundBall" & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`LD%` = 100 * sum(AutoHitType == "LineDrive" & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`FB%` = 100 * sum(AutoHitType == "FlyBall" & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`PU%` = 100 * sum(AutoHitType == "Popup" & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Pull%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) & PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Straight%` = 100 * sum(Bearing >= -15 & Bearing <= 15 & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Oppo%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) & PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Pull GB%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing < -15, Bearing > 15) &
!AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Straight GB%` = 100 * sum(Bearing >= -15 & Bearing <= 15 &
!AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Oppo GB%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) &
!AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Straight Air%` = 100 * sum(Bearing >= -15 & Bearing <= 15 &
AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
`Oppo Air%` = 100 * sum(replace_na(
if_else(BatterSide == "Right", Bearing > 15, Bearing < -15) &
AutoHitType %in% c("FlyBall", "LineDrive", "Popup") & PitchCall == "InPlay", FALSE), na.rm = TRUE) /
sum(PitchCall == "InPlay", na.rm = TRUE),
.groups = "drop"
) %>%
mutate(across(-c(Batter), as.numeric)) %>%
mutate(
across(where(is.numeric),
~ case_when(
grepl("%$", cur_column()) ~ round(.x, 1),
cur_column() %in% c("xwOBAcon", "xwOBA", "xBA", "xSLG", "Avg" ,"OBP", "SLG") ~ round(.x, 3),
cur_column() %in% c("Barrels/PA", "Avg EV", "EV90", "Max EV", "Decisions" ,"OBP", "SLG") ~ round(.x, 1),
TRUE ~ .x
)
)
)
}
pitch_summary_game <- function(data, player) {
data <- data %>%
filter(Pitcher == player)
pitcher_summary <- data %>%
summarise(
IP = round(sum(OutsOnPlay, na.rm = TRUE) / 3, 2),
P = n(),
PA = sprintf("%.0f", sum(is_plate_appearance, na.rm = TRUE)),
`H/9` = sprintf("%.1f", 9 * sum(is_hit, na.rm = TRUE) / IP),
`K/9` = sprintf("%.1f", 9 * sum(is_k, na.rm = TRUE) / IP),
`BB/9` = sprintf("%.1f", 9 * sum(is_walk, na.rm = TRUE) / IP),
`R/9` = sprintf("%.1f", 9 * sum(RunsScored, na.rm = TRUE) / IP),
`HR/9` = sprintf("%.1f", 9 * sum(PlayResult == "Homerun", na.rm = TRUE) / IP),
BBE = sprintf("%.0f", sum(PitchCall == "InPlay", na.rm = TRUE)),
`Strike%` = sprintf("%.1f", 100 * sum(!PitchCall %in% c("BallCalled", "HitByPitch", "BallinDirt", "BallIntentional", "Undefined")) / n()),
`CSW%` = sprintf("%.1f", 100 * mean(is_csw, na.rm = TRUE)),
`Chase%` = sprintf("%.1f", 100 * mean(chase, na.rm = TRUE)),
`Zone%` = sprintf("%.1f", 100 * mean(in_zone, na.rm = TRUE)),
`Whiff%` = sprintf("%.1f", 100 * mean(is_whiff, na.rm = TRUE)),
`Z-Whiff%` = sprintf("%.1f", 100 * mean(in_zone_whiff, na.rm = TRUE)),
`Put Away%` = sprintf("%.1f", 100 * mean(is_put_away, na.rm = TRUE)),
xwOBAcon = sprintf("%.3f", mean(xwOBA[PitchCall == "InPlay"], na.rm = TRUE)),
Stuff = sprintf("%.0f", mean(stuff, na.rm = TRUE))
) %>%
mutate(IP = case_when(
abs(IP %% 1 - 0.33) < 0.01 ~ floor(IP) + 0.1,
abs(IP %% 1 - 0.67) < 0.01 ~ floor(IP) + 0.2,
TRUE ~ IP
)) %>%
ungroup()
pitcher_summary <- pitcher_summary %>%
select(IP, P, PA, BBE, `H/9`, `K/9`, `BB/9`, `R/9`, `HR/9`, `Strike%`, `CSW%`, `Chase%`, `Zone%`, `Whiff%`, `Z-Whiff%`, `Put Away%`, xwOBAcon, Stuff) %>%
mutate(across(everything(), ~as.numeric(.)))
unique_dates <- unique(data$Date)
opponent_name <- data %>%
filter(Pitcher == player) %>%
slice_head(n = 1) %>%
pull(BatterTeam)
title_text <- if (length(unique_dates) == 1 & opponent_name == "WVN_MN2") {
paste(unique_dates[1])
} else if (length(unique_dates) == 1 & opponent_name != "WVN_MN2"){
paste(unique_dates[1], " vs ", opponent_name)
} else {
paste(min(unique_dates), "-", max(unique_dates))
}
pitcher_summary %>%
gt() %>%
wvu_gt_theme(title = title_text) %>%
data_color(columns = Stuff, colors = make_color_fn(80, 120)) %>%
data_color(columns = `K/9`, colors = make_color_fn(
quantile(summary_df_pitcher$`K/9`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`K/9`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Strike%`, colors = make_color_fn(50, 70)) %>%
data_color(columns = `CSW%`, colors = make_color_fn(18, 40)) %>%
data_color(columns = `Chase%`, colors = make_color_fn(
quantile(summary_df_pitcher$`Chase%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Chase%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Whiff%`, colors = make_color_fn(
quantile(summary_df_pitcher$`Whiff%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Whiff%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Z-Whiff%`, colors = make_color_fn(
quantile(summary_df_pitcher$`Z-Whiff%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Z-Whiff%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Zone%`, colors = make_color_fn(
quantile(summary_df_pitcher$`Zone%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Zone%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `Put Away%`, colors = make_color_fn(
quantile(summary_df_pitcher$`Put Away%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Put Away%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `H/9`, colors = make_color_fn_reverse(
quantile(summary_df_pitcher$`H/9`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`H/9`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `R/9`, colors = make_color_fn_reverse(
quantile(summary_df_pitcher$`R/9`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`R/9`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `HR/9`, colors = make_color_fn_reverse(
quantile(summary_df_pitcher$`HR/9`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`HR/9`, 0.9, na.rm = TRUE))) %>%
data_color(columns = `BB/9`, colors = make_color_fn_reverse(
quantile(summary_df_pitcher$`BB/9`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`BB/9`, 0.9, na.rm = TRUE))) %>%
data_color(columns = xwOBAcon, colors = make_color_fn_reverse(
quantile(summary_df_pitcher$xwOBAcon, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$xwOBAcon, 0.9, na.rm = TRUE))) %>%
fmt_missing(columns = everything(), missing_text = "-")
}
plot_pitch_type_freq <- function(data, player) {
player_total <- data %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
nrow()
if (player_total == 0) {
return(ggplot() + theme_void())
}
df <- data %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
group_by(TaggedPitchType) %>%
mutate(n = 100 * n() / player_total) %>%
filter(n >= 1) %>%
ungroup()
plot_data <- df %>%
filter(!is.na(TaggedPitchType),
Pitcher == player) %>%
mutate(Hand = ifelse(BatterSide == "Right", "RHH", "LHH")) %>%
group_by(Hand) %>%
mutate(total_side = n()) %>%
group_by(TaggedPitchType, Hand, total_side) %>%
summarise(count = n(), .groups = "drop") %>%
mutate(pct = 100 * count / total_side) %>%
select(TaggedPitchType, Hand, pct)
pitch_order <- plot_data %>%
mutate(pct_adj = ifelse(Hand == "LHH", -pct, pct)) %>%
group_by(TaggedPitchType) %>%
summarise(total = sum(abs(pct_adj)), .groups = "drop") %>%
arrange(desc(total)) %>%
pull(TaggedPitchType)
plot_data$TaggedPitchType <- factor(plot_data$TaggedPitchType,
levels = rev(pitch_order))
plot_data$pct_adj <- ifelse(plot_data$Hand == "LHH", -plot_data$pct, plot_data$pct)
ggplot(plot_data, aes(x = pct_adj, y = TaggedPitchType, fill = TaggedPitchType)) +
geom_vline(xintercept = 20, color = "black", linetype = "dashed", alpha = .3) +
geom_vline(xintercept = 40, color = "black", linetype = "dashed", alpha = .3) +
geom_vline(xintercept = 60, color = "black", linetype = "dashed", alpha = .3) +
geom_vline(xintercept = 80, color = "black", linetype = "dashed", alpha = .3) +
geom_vline(xintercept = 100, color = "black", linetype = "dashed", alpha = .3) +
geom_vline(xintercept = -20, color = "black", linetype = "dashed", alpha = .3) +
geom_vline(xintercept = -40, color = "black", linetype = "dashed", alpha = .3) +
geom_vline(xintercept = -60, color = "black", linetype = "dashed", alpha = .3) +
geom_vline(xintercept = -80, color = "black", linetype = "dashed", alpha = .3) +
geom_vline(xintercept = -100, color = "black", linetype = "dashed", alpha = .3) +
geom_vline(xintercept = 0, color = "black", linetype = "dashed", alpha = .5) +
geom_col(width = 0.7, position = "identity") +
geom_text(aes(label = paste0(round(abs(pct), 0), "%")),
hjust = ifelse(plot_data$pct_adj > 0, -0.2, 1.2),
size = 3.5,
fontface = "bold") +
geom_vline(xintercept = 0, color = "white") +
scale_fill_manual(values = pitch_colors) +
theme_void() +
ggtitle("LHH Pitch Usage RHH") +
theme(
legend.position = "none",
plot.title = element_text(hjust = .5)
) +
xlim(-110, 110)
}
tilt <- function(data, player) {
hour_positions <- data.frame(
hour = 1:12,
angle = seq(30, 360, by = 30)
)
types <- data %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
group_by(TaggedPitchType) %>%
summarise(n = 100 * n() / nrow(data %>%
filter(Pitcher == player))) %>%
filter(n >= 1)
types <- unique(types$TaggedPitchType)
pitches <- data %>%
mutate(SpinAxis = SpinAxis + 180) %>%
mutate(SpinAxis = ifelse(SpinAxis > 360, SpinAxis - 360, SpinAxis)) %>%
filter(Pitcher == player & TaggedPitchType %in% types) %>%
group_by(TaggedPitchType) %>%
summarise(angle = round(median(SpinAxis, na.rm = TRUE)))
clock_plot <- ggplot() +
geom_circle(aes(x0 = 0, y0 = 0, r = 1), size = 1, color = "black", fill = "white") +
coord_fixed() +
theme_void()
hour_positions <- data.frame(
hour = 1:12,
angle = seq(30, 360, by = 30)
)
clock_plot <- clock_plot +
geom_text(data = hour_positions,
aes(x = 0.85 * cos(pi/180 * (90 - angle)),
y = 0.85 * sin(pi/180 * (90 - angle)),
label = hour), size = 5)
clock_plot <- clock_plot +
geom_segment(data = pitches,
aes(x = 0, y = 0,
xend = cos(pi/180 * (90 - angle)),
yend = sin(pi/180 * (90 - angle)),
color = TaggedPitchType),
size = 1, arrow = arrow(length = unit(0.3, "cm"))) +
geom_circle(aes(x0 = 0, y0 = 0, r = .25), size = 1, color = "black", fill = "white") +
geom_circle(aes(x0 = 0, y0 = 0, r = .06), size = 1, color = "black", fill = "black")
clock_plot <- clock_plot +
scale_color_manual(values = pitch_colors) +
ggtitle(paste0(" ")) +
ggtitle("Pitch Tilts") +
theme(plot.title = element_text(size = 12, hjust = .5),
legend.position = "none")
print(clock_plot)
}
stuff_by_date <- function(data, pitcher){
data %>%
dplyr::filter(Pitcher == pitcher,
!is.na(TaggedPitchType),
!is.na(Date),
TaggedPitchType != "Other") %>%
mutate(Date = lubridate::ymd(Date)) %>%
arrange(Date) %>%
mutate(Date_label = format(Date, "%b %d"),
Date_label = factor(Date_label, levels = unique(Date_label))) %>%
ggplot2::ggplot(aes(x = Date_label, y = stuff, color = TaggedPitchType)) +
ggplot2::geom_hline(yintercept = 100, linetype = "dotted") +
ggplot2::stat_summary(fun = mean, geom = "line", linewidth = 1) +
ggplot2::stat_summary(fun = mean, geom = "point", size = 3) +
ggplot2::stat_summary(fun.data = mean_se, geom = "errorbar", width = 1) +
ggplot2::scale_color_manual(values = pitch_colors) +
ggplot2::labs(
y = "Stuff+",
x = "Date",
color = " "
) +
ggplot2::theme_bw() +
ggplot2::theme(
axis.text.x = ggplot2::element_text(size = 12, angle = 45),
axis.text.y = ggplot2::element_text(size = 18),
axis.title.x = ggplot2::element_text(size = 18),
axis.title.y = ggplot2::element_text(size = 18),
legend.text = ggplot2::element_text(size = 18),
legend.title = ggplot2::element_blank(),
legend.key.size = ggplot2::unit(2, "lines"),
plot.margin = ggplot2::margin(10, 10, 10, 10)
)
}
long_form <- function(df, player) {
player_total <- df %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
nrow()
if (player_total == 0) {
return(ggplot() + theme_void())
}
df <- df %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
group_by(TaggedPitchType) %>%
mutate(n = 100 * n() / player_total) %>%
filter(n >= 1) %>%
ungroup()
min_break <- df %>%
filter(Pitcher == player) %>%
summarise(min = floor((round(min(VertBreak, na.rm = TRUE)) - 11) / 10) * 10) %>%
pull(min)
df <- df %>%
group_by(BatterSide) %>%
mutate(mean_RelSide = mean(RelSide, na.rm = TRUE)) %>%
ungroup() %>%
filter((abs(RelSide) - abs(mean_RelSide)) < .5)
df %>%
filter(Pitcher == player) %>%
ggplot(aes(x = HorzBreak, y = VertBreak)) +
geom_vline(xintercept = 0, linetype = "dashed") +
geom_point(aes(fill = TaggedPitchType), alpha = .8, shape = 21, color = "black", stroke = .5, size = 3.5) +
annotate("text", x = -29, y = 0,
label = "← 1B", color = "black", size = 3, hjust = 0.5) +
annotate("text", x = 29, y = 0,
label = "3B →", color = "black", size = 3, hjust = 0.5) +
scale_x_continuous("Horizontal Movement (in)", limits = c(-27.5, 27.5), breaks = seq(-20, 20, by = 10)) +
scale_y_continuous("Vertical Movement (in)", limits = c(min_break, 0), breaks = seq(min_break, 0, by = 10)) +
scale_fill_manual(values = pitch_colors) +
scale_color_manual(values = pitch_colors) +
theme_minimal() +
ggtitle("Long Form") +
theme(
plot.title = element_text(size = 12, hjust = .5),
legend.position = "none",
panel.background = element_rect(fill = "#ffffff"),
legend.title = element_blank(),
axis.text.x = element_text(size = 12),
axis.text.y = element_text(size = 12),
axis.title.x = element_text(size = 12),
axis.title.y = element_text(size = 12)
)
}
locations <- function(data, player) {
data <- data %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
group_by(TaggedPitchType) %>%
mutate(n = 100 * n() / nrow(data %>% filter(Pitcher == player))) %>%
filter(n >= 2) %>%
ungroup()
player_data <- data %>%
mutate(
BatterSide = ifelse(BatterSide == "Right", "Vs Right", "Vs Left"),
TaggedPitchType = factor(TaggedPitchType)
)
pitch_count <- n_distinct(player_data$TaggedPitchType)
player_data %>%
ggplot(aes(PlateLocSide, PlateLocHeight)) +
stat_density_2d(
aes(fill = after_stat(ndensity)),
geom = "raster", contour = FALSE
) +
facet_grid(BatterSide ~ TaggedPitchType, labeller = label_value) +
geom_rect(
xmin = -8.5, xmax = 8.5,
ymin = 18, ymax = 42,
fill = NA, color = "black", linewidth = 0.4
) +
coord_fixed() +
scale_x_continuous("", limits = c(-15, 15)) +
scale_y_continuous("", limits = c(10, 50)) +
theme_void() +
scale_fill_gradientn(
colors = c("#315aa1", "grey80", "#d72029"),
values = scales::rescale(c(0, 0.5, 1)),
limits = c(0, 1),
guide = "none"
) +
theme(
strip.text.x = element_text(size = 15),
strip.text.y.right = element_text(size = 15, angle = 0, hjust = 0),
strip.placement = "outside",
strip.background = element_blank(),
panel.background = element_rect(fill = "#ffffff", color = NA),
legend.position = "none"
)
}
count_usage <- function(data, player){
data <- data %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
group_by(TaggedPitchType) %>%
mutate(n = 100 * n() / nrow(data %>% filter(Pitcher == player))) %>%
filter(n >= 2) %>%
ungroup()
data %>%
mutate(
count = case_when(
Balls == 0 & Strikes == 0 ~ "0-0",
Balls == 3 & Strikes == 2 ~ "3-2",
Balls > Strikes ~ "Behind",
Strikes > Balls ~ "Ahead",
Balls == Strikes ~ "Tied"
),
BatterSide = ifelse(BatterSide == "Right", "Vs Right", "Vs Left")
) %>%
group_by(count, BatterSide) %>%
mutate(total_count = n()) %>%
group_by(count, TaggedPitchType, BatterSide) %>%
summarise(n = n(), total = first(total_count), .groups = "drop") %>%
mutate(percentage = n / total * 100) %>%
arrange(desc(percentage)) %>%
ggplot(aes(x = "", y = percentage, fill = TaggedPitchType)) +
geom_bar(width = 1, stat = "identity") +
coord_polar("y", start = 0) +
facet_grid(BatterSide ~ count, labeller = label_value) +
theme_minimal() +
labs(title = "Pitch Usage by Count", fill = "Pitch Type") +
scale_fill_manual(values = pitch_colors) +
theme(plot.title = element_text(hjust = 0.5, size = 12),
axis.text = element_blank(),
axis.title = element_blank(),
axis.ticks = element_blank(),
strip.text = element_text(size = 12),
legend.position = "none"
)
}
at_bats <- function(data, player) {
df <- data %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
arrange(PitchNo) %>%
group_by(Inning, PAofInning) %>%
mutate(pa_number = cur_group_id()) %>%
ungroup() %>%
mutate(PitchCall = case_when(
PitchCall == "StrikeSwinging" ~ "Whiff",
PitchCall == "InPlay" ~ "In Play",
PitchCall == "FoulBall" ~ "Foul",
PitchCall == "BallCalled" ~ "Ball",
PitchCall == "StrikeCalled" ~ "CS",
PitchCall == "BallinDirt" ~ "Ball",
PitchCall == "HitByPitch" ~ "HBP",
PitchCall == "FoulBallNotFieldable" ~ "Foul",
PitchCall == "FoulBallFieldable" ~ "Foul",
PitchCall == "BallIntentional" ~ "Ball",
TRUE ~ PitchCall
))
total_pa <- max(df$pa_number, na.rm = TRUE)
if (total_pa < 8) {
empty_pn <- (total_pa + 1):8
empty_df <- tibble(
PlateLocSide = NA, PlateLocHeight = NA, PitchCall = NA,
PitchofPA = NA, PlayResult = NA, ExitSpeed = NA,
Batter = NA, Inning = NA, PAofInning = NA, BatterSide = NA,
TaggedPitchType = NA, pa_number = empty_pn
)
df <- bind_rows(df, empty_df)
total_pa <- 8
}
df <- df %>%
mutate(
pa_number = factor(pa_number, levels = 1:total_pa),
is_empty = is.na(PlateLocSide)
)
ggplot(df, aes(PlateLocSide, PlateLocHeight)) +
geom_rect(
xmin = -8.5, xmax = 8.5,
ymin = 18, ymax = 42,
fill = NA, color = "black"
) +
geom_point(
data = df %>% filter(!is_empty),
aes(fill = TaggedPitchType),
alpha = 1, shape = 21, color = "black", stroke = 0.5, size = 6
) +
geom_text(
data = df %>% filter(!is_empty),
aes(label = PitchofPA),
vjust = 0.5, size = 3.5, color = "white"
) +
geom_text(
data = df %>% filter(!is_empty),
aes(x = 33, y = 54 - (PitchofPA * 3),
label = ifelse(PitchCall == "In Play",
paste(PitchofPA, ": ", PlayResult),
paste(PitchofPA, ": ", PitchCall))),
inherit.aes = FALSE, size = 2.5
) +
geom_text(
data = df %>% filter(!is_empty),
aes(x = 33, y = 54 - (PitchofPA * 3) - 3,
label = ifelse(PitchCall == "In Play", paste0(round(ExitSpeed), " EV"), "")),
inherit.aes = FALSE, size = 2.5
) +
geom_text(
data = df %>% filter(!is_empty),
aes(x = 0, y = 54.5, label = Batter),
size = 3, fontface = "bold", hjust = 0.5
) +
geom_text(
data = df %>% filter(!is_empty),
aes(x = 32, y = 54.5, label = paste0("Inning ", Inning, ", PA ", PAofInning)),
size = 3, hjust = 0.5
) +
geom_text(
data = df %>% filter(!is_empty),
aes(x = ifelse(BatterSide == "Right", 15, -15), y = 30,
label = ifelse(BatterSide == "Right", "R", "L")),
size = 4, fontface = "bold"
) +
facet_wrap(~ pa_number, ncol = 6) +
theme_void() +
scale_x_continuous("", limits = c(-24, 40)) +
scale_y_continuous("", limits = c(5, 55)) +
coord_fixed() +
scale_fill_manual(values = pitch_colors, na.value = "grey90") +
labs(fill = "Pitch Type") +
ggtitle(player) +
theme(
panel.background = element_rect(fill = "#ffffff"),
legend.position = "top",
plot.title = element_blank(),
strip.text = element_text(size = 12, vjust = 1),
strip.placement = "outside",
strip.background = element_blank()
)
}
locations_game <- function(data, player, batter_side = NA) {
df <- data %>%
filter(Pitcher == player,
TaggedPitchType != "Other")
if (!is.na(batter_side)) {
df <- df %>% filter(BatterSide == batter_side)
}
if (nrow(df) == 0) {
return(
ggplot() +
geom_rect(xmin = -8.5, xmax = 8.5, ymin = 18, ymax = 42,
fill = NA, color = "black") +
theme_void() +
scale_x_continuous("", limits = c(-20, 20)) +
scale_y_continuous("", limits = c(5, 55)) +
coord_fixed() +
ggtitle(paste0("Locations vs ", batter_side)) +
theme(
panel.background = element_rect(fill = "#ffffff"),
plot.title = element_text(size = 12, hjust = .5, vjust = 1)
)
)
}
pitch_count <- n_distinct(df$TaggedPitchType)
plot <- df %>%
ggplot(aes(PlateLocSide, PlateLocHeight, fill = TaggedPitchType)) +
geom_point(alpha = .8, shape = 21, color = "black", stroke = .5, size = 5) +
facet_wrap(~ TaggedPitchType, ncol = pitch_count,
labeller = labeller(TaggedPitchType = ~ "")) +
geom_rect(xmin = -8.5, xmax = 8.5, ymin = 18, ymax = 42,
fill = NA, color = "black") +
theme_void() +
scale_x_continuous("", limits = c(-20, 20)) +
scale_y_continuous("", limits = c(0, 55)) +
coord_fixed() +
scale_fill_manual(values = pitch_colors) +
theme(
panel.background = element_rect(fill = "#ffffff"),
plot.title = element_text(size = 12, hjust = .5, vjust = 1),
legend.position = "none",
strip.text = element_text(size = 12, vjust = 1),
strip.placement = "outside",
strip.background = element_blank()
)
if (!is.na(batter_side)) {
plot <- plot + ggtitle(paste0("Locations vs ", batter_side))
} else {
plot <- plot + ggtitle(paste0("Locations"))
}
plot
}
actual_pitches_stuff <- function(player){
player_df <- get_pitcher_context_data(player)
player_total <- player_df %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
nrow()
if (player_total == 0) {
return(gt(tibble(Message = "No pitch data available")) %>% wvu_gt_theme(title = "Current Pitches"))
}
df <- player_df %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
group_by(TaggedPitchType) %>%
mutate(n = 100 * n() / player_total) %>%
filter(n >= 1) %>%
ungroup()
df %>%
filter(Pitcher == player, !TaggedPitchType %in% c("Other", "Underfined", NA)) %>%
group_by(TaggedPitchType) %>%
summarise(
HB = round(mean(HorzBreak, na.rm = TRUE), 1),
IVB = round(mean(InducedVertBreak, na.rm = TRUE), 1),
Velo = round(mean(RelSpeed, na.rm = TRUE), 1),
RelS = round(mean(RelSide, na.rm = TRUE), 1),
RelH = round(mean(RelHeight, na.rm = TRUE), 1),
Ext = round(mean(Extension, na.rm = TRUE), 1),
Stuff = round(mean(stuff, na.rm = TRUE)),
Grade = round(mean(Grade, na.rm = TRUE))
) %>%
rename(Pitch = TaggedPitchType) %>%
select(Pitch, HB, IVB, Velo, RelS, RelH, Ext, Stuff, Grade) %>%
gt() %>%
wvu_gt_theme(title = "Current Pitches") %>%
data_color(
columns = Pitch,
colors = scales::col_factor(
palette = pitch_colors,
domain = names(pitch_colors),
na.color = "white"
)
) %>%
data_color(columns = Stuff, colors = make_color_fn(80, 120)) %>%
data_color(columns = Grade, colors = make_color_fn(20, 80))
}
new_pitch_plot <- function(player, pitch_type, hb, ivb){
player_df <- get_pitcher_context_data(player)
player_total <- player_df %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
nrow()
arm_angle_layer <- list()
movement_title <- NULL
if ("arm_angle" %in% names(player_df)) {
arm_angle_vals <- suppressWarnings(as.numeric(player_df$arm_angle))
if (any(is.finite(arm_angle_vals))) {
arm_angle_deg <- median(arm_angle_vals[is.finite(arm_angle_vals)], na.rm = TRUE)
arm_angle_deg <- max(min(arm_angle_deg, 90), 0)
movement_title <- paste0("Movement (Arm Angle: ", round(arm_angle_deg), "\u00b0)")
throw_hand <- NA_character_
if ("PitcherThrows" %in% names(player_df)) {
throw_vals <- as.character(player_df$PitcherThrows)
throw_vals <- throw_vals[!is.na(throw_vals) & throw_vals != ""]
if (length(throw_vals) > 0) {
throw_hand <- throw_vals[1]
}
}
is_lefty <- tolower(substr(throw_hand, 1, 1)) == "l"
if (isTRUE(all.equal(arm_angle_deg, 90, tolerance = 1e-6))) {
arm_angle_layer <- list(
annotate("segment", x = 0, y = -27.5, xend = 0, yend = 27.5,
linetype = "dashed", color = "gray35", linewidth = 0.8)
)
} else {
slope <- tan(arm_angle_deg * pi / 180)
if (is_lefty) slope <- -slope
arm_angle_layer <- list(
geom_abline(slope = slope, intercept = 0, linetype = "dashed", color = "gray35", linewidth = 0.8)
)
}
}
}
df <- player_df %>%
group_by(BatterSide) %>%
mutate(mean_RelSide = mean(RelSide, na.rm = TRUE)) %>%
ungroup() %>%
filter((abs(RelSide) - abs(mean_RelSide)) < .5)
if (player_total == 0) {
return(
ggplot() +
theme_void() +
ggtitle(movement_title) +
theme(
plot.title = element_text(hjust = 0.5, face = "bold"),
panel.background = element_rect(fill = "#ffffff")
)
)
}
df <- df %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
group_by(TaggedPitchType) %>%
mutate(n = 100 * n() / player_total) %>%
filter(n >= 1) %>%
ungroup()
df %>%
ggplot(aes(x = HorzBreak, y = InducedVertBreak)) +
geom_segment(aes(x = 0, y = -25, xend = 0, yend = 25), color = "black", linetype = "dashed") +
geom_segment(aes(x = -25, y = 0, xend = 25, yend = 0), color = "black", linetype = "dashed") +
arm_angle_layer +
geom_point(aes(fill = TaggedPitchType), alpha = .3, shape = 21, color = "black", stroke = .5,
size = 3.5) +
geom_point(aes(x = hb, y = ivb, fill = pitch_type), alpha = .8, shape = 21, color = "black", stroke = .5,
size = 8) +
annotate("text", x = -24, y = 25,
label = "← 1B", color = "black", size = 3, hjust = 0.5) +
annotate("text", x = 24, y = 25,
label = "3B →", color = "black", size = 3, hjust = 0.5) +
scale_x_continuous("Horizontal Movement (in)", limits = c(-25, 25), breaks = seq(-20, 20, by = 10)) +
scale_y_continuous("Induced Vertical Movement (in)", limits = c(-25, 25), breaks = seq(-20, 20, by = 10)) +
scale_fill_manual(values = pitch_colors) +
scale_color_manual(values = pitch_colors) +
coord_equal() +
theme_minimal() +
ggtitle(movement_title) +
theme(
plot.title = element_text(hjust = 0.5, face = "bold"),
legend.position = "none",
panel.background = element_rect(fill = "#ffffff"),
legend.title = element_blank(),
axis.text.x = element_text(size = 12),
axis.text.y = element_text(size = 12),
axis.title.x = element_text(size = 12),
axis.title.y = element_text(size = 12)
)
}
get_pitcher_arm_angle <- function(Pitcher, fallback = 45) {
arm_angle_vals <- get_pitcher_context_data(Pitcher) %>%
pull(.data$arm_angle)
arm_angle_vals <- suppressWarnings(as.numeric(arm_angle_vals))
arm_angle_vals <- arm_angle_vals[is.finite(arm_angle_vals)]
if (length(arm_angle_vals) == 0) {
return(fallback)
}
max(min(stats::median(arm_angle_vals, na.rm = TRUE), 90), 0)
}
get_new_pitch_defaults <- function(Pitcher) {
valid_pitch_types <- stuff_means$TaggedPitchType %>%
unique() %>%
setdiff(c("Other", "Undefined"))
pitcher_pitches <- get_pitcher_context_data(Pitcher) %>%
filter(
.data$Pitcher == .env$Pitcher,
!is.na(.data$TaggedPitchType),
.data$TaggedPitchType %in% valid_pitch_types
)
if (nrow(pitcher_pitches) == 0) {
return(list(
pitch_type = "Fastball",
hb = 0,
ivb = 0,
velo = 85
))
}
pitch_defaults <- pitcher_pitches %>%
group_by(.data$TaggedPitchType) %>%
summarise(
pitches = n(),
hb = mean(.data$HorzBreak, na.rm = TRUE),
ivb = mean(.data$InducedVertBreak, na.rm = TRUE),
velo = mean(.data$RelSpeed, na.rm = TRUE),
.groups = "drop"
)
default_row <- pitch_defaults %>%
filter(.data$TaggedPitchType == "Fastball")
if (nrow(default_row) == 0) {
default_row <- pitch_defaults %>%
arrange(desc(.data$pitches), .data$TaggedPitchType) %>%
slice(1)
}
list(
pitch_type = default_row$TaggedPitchType[[1]],
hb = round(default_row$hb[[1]], 1),
ivb = round(default_row$ivb[[1]], 1),
velo = round(default_row$velo[[1]], 1)
)
}
get_pitcher_fastball_reference <- function(Pitcher) {
fastball_row <- get_pitcher_context_data(Pitcher) %>%
filter(
.data$Pitcher == .env$Pitcher,
.data$TaggedPitchType == "Fastball"
) %>%
summarise(
fb_ivb = mean(.data$InducedVertBreak, na.rm = TRUE),
fb_velo = mean(.data$RelSpeed, na.rm = TRUE)
)
if (nrow(fastball_row) == 0 ||
!is.finite(fastball_row$fb_ivb[[1]]) ||
!is.finite(fastball_row$fb_velo[[1]])) {
return(list(
fb_ivb = NA_real_,
fb_velo = NA_real_
))
}
list(
fb_ivb = fastball_row$fb_ivb[[1]],
fb_velo = fastball_row$fb_velo[[1]]
)
}
get_pitcher_context_samples <- function(Pitcher, n_draws = 40, seed = 1) {
pitcher_rows <- get_pitcher_context_data(Pitcher)
rel_info <- get_relpoints() %>% filter(.data$Pitcher == .env$Pitcher)
if (nrow(rel_info) == 0 && nrow(pitcher_rows) > 0) {
rel_info <- pitcher_rows %>%
summarise(
RelSide = round(mean(.data$RelSide, na.rm = TRUE), 1),
RelHeight = round(mean(.data$RelHeight, na.rm = TRUE), 1),
Extension = round(mean(.data$Extension, na.rm = TRUE), 1)
)
}
if (nrow(rel_info) == 0 || nrow(pitcher_rows) == 0) {
stop("Pitcher context not found.")
}
fallback_rel_side <- rel_info$RelSide[[1]]
fallback_rel_height <- rel_info$RelHeight[[1]]
fallback_extension <- rel_info$Extension[[1]]
fallback_arm_angle <- get_pitcher_arm_angle(Pitcher)
fallback_primary_az0 <- pitcher_rows %>%
summarise(value = mean(.data$primary_az0, na.rm = TRUE)) %>%
pull(.data$value)
fallback_primary_velo <- pitcher_rows %>%
summarise(value = mean(.data$primary_velo, na.rm = TRUE)) %>%
pull(.data$value)
context_pool <- pitcher_rows %>%
transmute(
RelSide = suppressWarnings(as.numeric(.data$RelSide)),
RelHeight = suppressWarnings(as.numeric(.data$RelHeight)),
Extension = suppressWarnings(as.numeric(.data$Extension)),
arm_angle = suppressWarnings(as.numeric(.data$arm_angle)),
primary_az0 = suppressWarnings(as.numeric(.data$primary_az0)),
primary_velo = suppressWarnings(as.numeric(.data$primary_velo))
)
if (nrow(context_pool) == 0) {
context_pool <- tibble(
RelSide = fallback_rel_side,
RelHeight = fallback_rel_height,
Extension = fallback_extension,
arm_angle = fallback_arm_angle,
primary_az0 = fallback_primary_az0,
primary_velo = fallback_primary_velo
)
}
set.seed(seed)
sampled_context <- context_pool %>%
slice_sample(n = n_draws, replace = TRUE) %>%
mutate(
RelSide = ifelse(is.finite(.data$RelSide), .data$RelSide, fallback_rel_side),
RelHeight = ifelse(is.finite(.data$RelHeight), .data$RelHeight, fallback_rel_height),
Extension = ifelse(is.finite(.data$Extension), .data$Extension, fallback_extension),
arm_angle = ifelse(is.finite(.data$arm_angle), .data$arm_angle, fallback_arm_angle),
primary_az0 = ifelse(is.finite(.data$primary_az0), .data$primary_az0, fallback_primary_az0),
primary_velo = ifelse(is.finite(.data$primary_velo), .data$primary_velo, fallback_primary_velo)
)
sampled_context
}
coerce_to_model_ptype <- function(df_in, model) {
ptype <- model[["pre"]][["mold"]][["blueprint"]][["ptypes"]][["predictors"]]
common <- base::intersect(base::names(df_in), base::names(ptype))
for (nm in common) {
target <- ptype[[nm]]
if (base::is.factor(target)) {
df_in[[nm]] <- base::factor(base::as.character(df_in[[nm]]), levels = base::levels(target))
} else if (base::is.integer(target)) {
df_in[[nm]] <- suppressWarnings(base::as.integer(df_in[[nm]]))
} else if (base::is.numeric(target)) {
df_in[[nm]] <- suppressWarnings(base::as.numeric(df_in[[nm]]))
} else if (base::is.logical(target)) {
df_in[[nm]] <- base::as.logical(df_in[[nm]])
} else {
df_in[[nm]] <- base::as.character(df_in[[nm]])
}
}
df_in
}
build_new_pitch_prediction <- function(Pitcher, pitch_type, hb, ivb, RelSpeed, arm_angle = NULL) {
fastball_reference <- get_pitcher_fastball_reference(Pitcher)
context_samples <- get_pitcher_context_samples(Pitcher)
throws_values <- get_pitcher_context_data(Pitcher) %>%
pull(.data$PitcherThrows)
throws_values <- throws_values[!is.na(throws_values) & throws_values != ""]
is_lefty <- length(throws_values) > 0 && stats::median(as.integer(throws_values == "Left")) >= 1
if (!is.null(arm_angle)) {
arm_angle <- suppressWarnings(as.numeric(arm_angle))
if (is.finite(arm_angle)) {
context_samples$arm_angle <- max(min(arm_angle, 90), 0)
}
}
movement_data <- context_samples %>%
transmute(
HorzBreak = if (is_lefty) hb else -hb,
InducedVertBreak = ivb,
RelSpeed = RelSpeed,
RelSide = if (is_lefty) .data$RelSide else -.data$RelSide,
RelHeight = .data$RelHeight,
Extension = .data$Extension,
arm_angle = pmax(pmin(.data$arm_angle, 90), 0),
primary_az0 = .data$primary_az0,
primary_velo = .data$primary_velo
)
conversion_inputs <- movement_data %>%
mutate(
HorzBreak_model = .data$HorzBreak,
RelSide_model = .data$RelSide
)
model_features_samples <- conversion_inputs %>%
mutate(
ax0 = predict(get_stuff_conversion_models()$ax0, newdata = conversion_inputs),
az0 = predict(get_stuff_conversion_models()$az0, newdata = conversion_inputs),
ZoneTime = predict(get_stuff_conversion_models()$zonetime, newdata = conversion_inputs),
az0_diff = if (pitch_type == "Fastball") 0 else .data$az0 - .data$primary_az0,
velo_diff = if (pitch_type == "Fastball") 0 else RelSpeed - .data$primary_velo
) %>%
select(ZoneTime, arm_angle, RelHeight, ax0, az0, az0_diff, velo_diff)
final_fit_stuff <- get_final_fit_stuff()
model_features_samples <- coerce_to_model_ptype(model_features_samples, final_fit_stuff)
xrv_samples <- predict(final_fit_stuff, model_features_samples)$.pred
mean_xrv <- mean(xrv_samples, na.rm = TRUE)
model_features <- model_features_samples %>%
summarise(across(everything(), ~ mean(.x, na.rm = TRUE)))
prediction_row <- model_features %>%
mutate(
xrv = mean_xrv,
stuff_z_score = (mean_xrv - stuff_means_overall$mean_xRV[[1]]) / stuff_means_overall$sd_xRV[[1]],
stuff = stuff_z_score * 10 + 100,
TaggedPitchType = pitch_type
) %>%
select(-stuff_z_score) %>%
left_join(stuff_means, by = "TaggedPitchType") %>%
mutate(
Grade = ((xrv - mean_xRV) / sd_xRV) * 10 + 50,
Grade = round(pmax(pmin(Grade, 80), 20))
)
list(
display_row = tibble(
Pitch = pitch_type,
HB = hb,
IVB = ivb,
Velo = RelSpeed,
`Arm Angle` = round(mean(context_samples$arm_angle, na.rm = TRUE), 1),
RelS = round(mean(context_samples$RelSide, na.rm = TRUE), 1),
RelH = round(mean(context_samples$RelHeight, na.rm = TRUE), 1),
Ext = round(mean(context_samples$Extension, na.rm = TRUE), 1),
Stuff = round(prediction_row$stuff[[1]]),
Grade = round(prediction_row$Grade[[1]])
),
model_features = model_features,
model_features_samples = model_features_samples,
prediction_row = prediction_row,
display_ivb_diff = if (pitch_type == "Fastball") {
0
} else if (is.finite(fastball_reference$fb_ivb)) {
ivb - fastball_reference$fb_ivb
} else {
NA_real_
}
)
}
new_pitch_stuff <- function(Pitcher, pitch_type, hb, ivb, RelSpeed, arm_angle = NULL) {
prediction <- build_new_pitch_prediction(Pitcher, pitch_type, hb, ivb, RelSpeed, arm_angle)
prediction$display_row %>%
gt() %>%
wvu_gt_theme(title = "New Pitch") %>%
data_color(
columns = Pitch,
colors = scales::col_factor(
palette = pitch_colors,
domain = names(pitch_colors),
na.color = "white"
)
) %>%
data_color(columns = Stuff, colors = make_color_fn(80, 120)) %>%
data_color(columns = Grade, colors = make_color_fn(20, 80))
}
new_pitch_shap_plot <- function(Pitcher, pitch_type, hb, ivb, RelSpeed, arm_angle = NULL) {
prediction <- build_new_pitch_prediction(Pitcher, pitch_type, hb, ivb, RelSpeed, arm_angle)
final_fit_stuff <- get_final_fit_stuff()
trained_recipe <- workflows::extract_recipe(final_fit_stuff, estimated = TRUE)
model_matrix <- recipes::bake(trained_recipe, new_data = prediction$model_features_samples) %>%
as.matrix()
booster <- workflows::extract_fit_engine(final_fit_stuff)
shap_values <- stats::predict(booster, newdata = model_matrix, predcontrib = TRUE)
if (is.null(dim(shap_values))) {
shap_values <- matrix(shap_values, nrow = 1)
}
if (nrow(shap_values) > 1) {
shap_values_mean <- colMeans(shap_values)
shap_values <- matrix(shap_values_mean, nrow = 1)
colnames(shap_values) <- names(shap_values_mean)
}
overall_mean <- stuff_means_overall$mean_xRV[[1]]
overall_sd <- stuff_means_overall$sd_xRV[[1]]
stuff_scale <- 10 / overall_sd
shap_contrib_raw <- shap_values[, -ncol(shap_values), drop = FALSE] * stuff_scale
baseline_stuff <- 100 + ((shap_values[1, ncol(shap_values)] - overall_mean) / overall_sd) * 10
shap_contrib <- matrix(
c(
shap_contrib_raw[, "ZoneTime"],
shap_contrib_raw[, "ax0"],
shap_contrib_raw[, "az0"],
shap_contrib_raw[, "az0_diff"],
shap_contrib_raw[, "velo_diff"],
shap_contrib_raw[, "arm_angle"],
shap_contrib_raw[, "RelHeight"]
),
nrow = 1
)
colnames(shap_contrib) <- c("Velocity", "HB", "iVB", "iVB vs FB", "Velo vs FB", "Arm Angle", "Release Height")
display_features <- tibble(
Velocity = sprintf("%.1f", RelSpeed),
HB = sprintf("%.1f", hb),
iVB = sprintf("%.1f", ivb),
`iVB vs FB` = if (is.finite(prediction$display_ivb_diff)) sprintf("%.1f", prediction$display_ivb_diff) else "No FB",
`Velo vs FB` = sprintf("%.1f", prediction$model_features$velo_diff[[1]]),
`Arm Angle` = sprintf("%.1f", prediction$model_features$arm_angle[[1]]),
`Release Height` = sprintf("%.1f", prediction$model_features$RelHeight[[1]])
)
pred_stuff <- baseline_stuff + sum(shap_contrib[1, ])
display_count <- ncol(display_features)
shapviz::shapviz(shap_contrib, X = display_features, baseline = baseline_stuff) %>%
shapviz::sv_waterfall(
max_display = ncol(display_features),
format_shap = function(x) sprintf("%.1f", x),
format_feat = as.character,
show_annotation = FALSE,
fill_colors = c(wvu_gold, wvu_blue)
) +
annotate(
"segment",
x = c(pred_stuff, baseline_stuff),
xend = c(pred_stuff, baseline_stuff),
y = c(display_count, 1),
yend = c(display_count, 1) + display_count * c(0.075, -0.075) + 0.13 * c(1, -1),
linewidth = 0.3,
linetype = 2
) +
labs(
title = "Stuff Model Prediction Explanation",
subtitle = paste0(
"Predicted Stuff: ",
round(prediction$prediction_row$stuff[[1]])
),
x = "Stuff"
) +
theme(
plot.title = element_text(face = "bold", size = 18, hjust = 0.5),
plot.subtitle = element_text(size = 16, hjust = 0.5),
axis.title.x = element_text(size = 15, face = "bold"),
axis.text.x = element_text(size = 13),
axis.text.y = element_text(size = 13)
)
}
stuff_movement <- function(data, player){
data <- data %>%
filter(Pitcher == player, TaggedPitchType != "Other") %>%
group_by(TaggedPitchType) %>%
mutate(n = 100 * n() / nrow(data %>%
filter(Pitcher == player))) %>%
filter(n >= 2) %>%
ungroup()
data <- data %>%
group_by(BatterSide) %>%
mutate(mean_RelSide = mean(RelSide, na.rm = TRUE)) %>%
ungroup() %>%
filter((abs(RelSide) - abs(mean_RelSide)) < .5)
plot <- data %>%
ggplot(aes(HorzBreak, InducedVertBreak)) +
geom_segment(aes(x = 0, y = -25, xend = 0, yend = 25), color = "black", linetype = "dashed") +
geom_segment(aes(x = -25, y = 0, xend = 25, yend = 0), color = "black", linetype = "dashed") +
stat_summary_hex(aes(z = stuff), fun = mean, bins = 16) +
scale_fill_gradient2(
low = "#002855",
mid = "lightgrey",
high = "#EAAA00",
midpoint = 100,
limits = c(75, 125),
oob = scales::squish,
name = "Stuff",
guide = guide_colorbar(barwidth = 1, barheight = 30)
) +
scale_x_continuous("Horizontal Movement (in)", limits = c(-25, 25), breaks = seq(-20, 20, by = 10)) +
scale_y_continuous("Induced Vertical Movement (in)", limits = c(-25, 25), breaks = seq(-20, 20, by = 10)) +
coord_equal() +
theme_minimal() +
facet_wrap(~ TaggedPitchType, ncol = 4) +
theme(
plot.title = element_text(size = 20, hjust = .5),
legend.position = "right",
panel.background = element_rect(fill = "#ffffff"),
axis.text.x = element_text(size = 20),
axis.text.y = element_text(size = 20),
axis.title.x = element_text(size = 20),
strip.text = element_text(size = 20, face = "bold"),
axis.title.y = element_text(size = 20)
)
print(plot)
}
pitcher_table <- function(df){
df %>%
group_by(Pitcher) %>%
summarise(
IP = round(sum(OutsOnPlay, na.rm = TRUE) / 3, 2),
P = n(),
PA = sprintf("%.0f", sum(is_plate_appearance, na.rm = TRUE)),
BBE = sprintf("%.0f", sum(PitchCall == "InPlay", na.rm = TRUE)),
`H/9` = sprintf("%.1f", 9 * sum(is_hit, na.rm = TRUE) / IP),
`K/9` = sprintf("%.1f", 9 * sum(is_k, na.rm = TRUE) / IP),
`BB/9` = sprintf("%.1f", 9 * sum(is_walk, na.rm = TRUE) / IP),
`R/9` = sprintf("%.1f", 9 * sum(RunsScored, na.rm = TRUE) / IP),
`HR/9` = sprintf("%.1f", 9 * sum(PlayResult == "Homerun", na.rm = TRUE) / IP),
`Strike%` = sprintf("%.1f", 100 * sum(!PitchCall %in% c("BallCalled", "HitByPitch", "BallinDirt", "BallIntentional", "Undefined")) / n()),
`CSW%` = sprintf("%.1f", 100 * mean(is_csw, na.rm = TRUE)),
`Chase%` = sprintf("%.1f", 100 * mean(chase, na.rm = TRUE)),
`Zone%` = sprintf("%.1f", 100 * mean(in_zone, na.rm = TRUE)),
`Put Away%` = sprintf("%.1f", 100 * mean(is_put_away, na.rm = TRUE)),
xBA = sprintf("%.3f", mean(xba, na.rm = TRUE)),
xwoba = sprintf("%.3f", mean(xwOBA, na.rm = TRUE)),
xwOBAcon = sprintf("%.3f", mean(xwOBA[PitchCall == "InPlay"], na.rm = TRUE)),
`FB Velo` = sprintf("%.1f", mean(RelSpeed[TaggedPitchType == "Fastball"],na.rm = TRUE)),
`Avg EV` = sprintf("%.1f", mean(ExitSpeed, na.rm = TRUE)),
`Barrel%` = sprintf("%.1f", 100 * mean(is_barrel, na.rm = TRUE)),
`Hard-Hit%` = sprintf("%.1f", 100 * mean(is_hard_hit, na.rm = TRUE)),
`GB%`= sprintf("%.1f", 100 *
(sum((AutoHitType == "GroundBall" & PitchCall == "InPlay"),
na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Decision Runs` = sprintf("%.2f", -100 * mean(sd_rv_added, na.rm = TRUE)),
`Whiff%` = sprintf("%.1f", 100 * mean(is_whiff, na.rm = TRUE)),
`Z-Whiff%` = sprintf("%.1f", 100 * (mean(in_zone_whiff, na.rm = TRUE))),
`K%` = sprintf("%.1f", 100 * mean(is_k, na.rm = TRUE)),
`BB%` = sprintf("%.1f", 100 * mean(is_walk, na.rm = TRUE)),
Stuff = sprintf("%.0f", mean(stuff, na.rm = TRUE))
) %>%
ungroup() %>%
mutate(across(-Pitcher, as.numeric)) %>%
arrange(-IP) %>%
rename(xwOBA = xwoba)
}
pitcher_table_by_hand <- function(df){
df %>%
group_by(Pitcher, TaggedPitchType) %>%
summarise(
IP = round(sum(OutsOnPlay, na.rm = TRUE) / 3, 2),
P = n(),
PA = sprintf("%.0f", sum(is_plate_appearance, na.rm = TRUE)),
BBE = sprintf("%.0f", sum(PitchCall == "InPlay", na.rm = TRUE)),
`H/9` = sprintf("%.1f", 9 * sum(is_hit, na.rm = TRUE) / IP),
`K/9` = sprintf("%.1f", 9 * sum(is_k, na.rm = TRUE) / IP),
`BB/9` = sprintf("%.1f", 9 * sum(is_walk, na.rm = TRUE) / IP),
`R/9` = sprintf("%.1f", 9 * sum(RunsScored, na.rm = TRUE) / IP),
`HR/9` = sprintf("%.1f", 9 * sum(PlayResult == "Homerun", na.rm = TRUE) / IP),
`Strike%` = sprintf("%.1f", 100 * sum(!PitchCall %in% c("BallCalled", "HitByPitch", "BallinDirt", "BallIntentional", "Undefined")) / n()),
`CSW%` = sprintf("%.1f", 100 * mean(is_csw, na.rm = TRUE)),
`Chase%` = sprintf("%.1f", 100 * mean(chase, na.rm = TRUE)),
`Zone%` = sprintf("%.1f", 100 * mean(in_zone, na.rm = TRUE)),
`Put Away%` = sprintf("%.1f", 100 * mean(is_put_away, na.rm = TRUE)),
xBA = sprintf("%.3f", mean(xba, na.rm = TRUE)),
xwoba = sprintf("%.3f", mean(xwOBA, na.rm = TRUE)),
xwOBAcon = sprintf("%.3f", mean(xwOBA[PitchCall == "InPlay"], na.rm = TRUE)),
`FB Velo` = sprintf("%.1f", mean(RelSpeed[TaggedPitchType == "Fastball"],na.rm = TRUE)),
`Avg EV` = sprintf("%.1f", mean(ExitSpeed, na.rm = TRUE)),
`Barrel%` = sprintf("%.1f", 100 * mean(is_barrel, na.rm = TRUE)),
`Hard-Hit%` = sprintf("%.1f", 100 * mean(is_hard_hit, na.rm = TRUE)),
`GB%`= sprintf("%.1f", 100 *
(sum((AutoHitType == "GroundBall" & PitchCall == "InPlay"),
na.rm = TRUE) / sum(PitchCall == "InPlay", na.rm = TRUE))),
`Decision Runs`= sprintf("%.2f", -100 * mean(sd_rv_added, na.rm = TRUE)),
`Whiff%` = sprintf("%.1f", 100 * mean(is_whiff, na.rm = TRUE)),
`Z-Whiff%` = sprintf("%.1f", 100 * (mean(in_zone_whiff, na.rm = TRUE))),
`K%` = sprintf("%.1f", 100 * mean(is_k, na.rm = TRUE)),
`BB%` = sprintf("%.1f", 100 * mean(is_walk, na.rm = TRUE)),
Stuff = sprintf("%.0f", mean(stuff, na.rm = TRUE))
) %>%
ungroup() %>%
mutate(across(!c(Pitcher, TaggedPitchType), as.numeric)) %>%
rename(`Pitch Type` = TaggedPitchType) %>%
arrange(desc(P)) %>%
rename(xwOBA = xwoba)
}
framing_by_zone <- function(df, catcher, cumulative = FALSE){
zone_values <- df %>%
mutate(
m1 = (sz_bot - sz_top) / (8.5 - (-8.5)),
b1 = sz_top - m1 * (-8.5),
m2 = (sz_bot - sz_top) / (-8.5 - 8.5),
b2 = sz_top - m2 * 8.5,
center_zone = sz_bot + ((sz_top - sz_bot) / 2),
zone_group = case_when(
between(PlateLocSide, -13, 13) & between(PlateLocHeight, center_zone - 16, center_zone + 16) ~ "Shadow",
TRUE ~ NA_character_
)
) %>%
filter(zone_group == "Shadow", is_swing == 0) %>%
mutate(
strike_prob = as.numeric(strike_prob),
is_csw = as.numeric(is_csw),
strike_added = is_csw - strike_prob,
diag1_z = m1 * PlateLocSide + b1,
diag2_z = m2 * PlateLocSide + b2,
zone = case_when(
PlateLocHeight > diag1_z & PlateLocHeight > diag2_z ~ "Top",
PlateLocHeight < diag1_z & PlateLocHeight < diag2_z ~ "Bottom",
PlateLocSide < 0 ~ "Left",
PlateLocSide > 0 ~ "Right"
)
) %>%
filter(Catcher == catcher) %>%
group_by(zone) %>% summarise(`Framing Run Value` = ifelse(cumulative == FALSE, round(100 *
.16 * mean(strike_added, na.rm = TRUE), 1),
round(.16 * sum(strike_added, na.rm = TRUE), 1)))
zones <- tibble::tribble(
~zone, ~x, ~z,
"Top", -10, 40,
"Top", 0, 30,
"Top", 10, 40,
"Bottom", -10, 20,
"Bottom", 0, 30,
"Bottom", 10, 20,
"Left", -10, 40,
"Left", 0, 30,
"Left", -10, 20,
"Right", 10, 40,
"Right", 0, 30,
"Right", 10, 20
) %>%
left_join(zone_values, by = "zone")
label_data <- tibble(
zone = c("Bottom", "Top", "Right", "Left"),
x = c(0, 0, 8, -8),
y = c(22, 38, 30, 30),
label = c(
zone_values$`Framing Run Value`[zone_values$zone == "Bottom"],
zone_values$`Framing Run Value`[zone_values$zone == "Top"],
zone_values$`Framing Run Value`[zone_values$zone == "Right"],
zone_values$`Framing Run Value`[zone_values$zone == "Left"]
)
)
plot <- ggplot(zones) +
geom_polygon(aes(x = x, y = z, fill = `Framing Run Value`, group = zone), color = NA) +
geom_rect(aes(xmin = -10, xmax = 10, ymin = 20, ymax = 40),
fill = NA, color = "black", linewidth = 1.2) +
geom_rect(aes(xmin = -6, xmax = 6, ymin = 24.05, ymax = 35.95),
fill = "white", color = "black", linewidth = 1.2) +
geom_segment(aes(x = -7.75, y = 12, xend = 7.75, yend = 12), color = "black") +
geom_segment(aes(x = -7.75, y = 12, xend = -8.75, yend = 14), color = "black") +
geom_segment(aes(x = 7.75, y = 12, xend = 8.75, yend = 14), color = "black") +
geom_segment(aes(x = 0, y = 16, xend = 8.75, yend = 14), color = "black") +
geom_segment(aes(x = 0, y = 16, xend = -8.75, yend = 14), color = "black") +
geom_segment(aes(x = 8, y = 22, xend = 8, yend = 38), color = "black", linetype = "dashed") +
geom_segment(aes(x = -8, y = 22, xend = -8, yend = 38), color = "black", linetype = "dashed") +
geom_segment(aes(x = -8, y = 22, xend = 8, yend = 22), color = "black", linetype = "dashed") +
geom_segment(aes(x = -8, y = 38, xend = 8, yend = 38), color = "black", linetype = "dashed") +
geom_label(
data = label_data,
aes(x = x, y = y, label = label),
size = 4,
color = "white",
fill = "black",
label.size = 0.25,
label.r = unit(0.15, "lines")
)
if (cumulative == FALSE){
plot + scale_fill_gradient2(
low = "#3661ad", mid = "white", high = "#d82029",
midpoint = 0, limits = c(-1, 1), name = " ",
oob = scales::squish,
guide = guide_colorbar(barheight = unit(4, "in"), barwidth = unit(0.3, "in"))
) +
coord_fixed() +
labs(title = paste0(catcher, " Framing Run Value / 100 Frames"),
x = " ", y = " ") +
theme_minimal() +
theme_void() +
theme(
legend.position = "right",
plot.title = element_text(hjust = .5)
)
} else {
plot + scale_fill_gradient2(
low = "#3661ad", mid = "white", high = "#d82029",
midpoint = 0, limits = c(-4, 4), name = " ",
oob = scales::squish,
guide = guide_colorbar(barheight = unit(4, "in"), barwidth = unit(0.3, "in"))
) +
coord_fixed() +
labs(title = paste0(catcher, " Framing Run Value"),
x = " ", y = " ") +
theme_minimal() +
theme_void() +
theme(
legend.position = "right",
plot.title = element_text(hjust = .5)
)
}
}
plot_catcher_times <- function(data, catcher) {
metric_colors <- c(
"Pop Time" = "#EAAA00",
"Throw Time" = "#002855",
"Exchange Time" = "#0062A3"
)
df_long <- data %>%
filter(Catcher == catcher) %>%
drop_na(BasePositionX, BasePositionY, BasePositionZ) %>%
mutate(
base_angle = atan2(BasePositionX, BasePositionZ) * (180 / pi),
ThrowBase = case_when(
between(base_angle, 70, 110) ~ "2B",
between(base_angle, 111, 180) ~ "3B",
TRUE ~ NA_character_
)
) %>%
filter(ThrowBase %in% c("2B")) %>%
mutate(across(c(PopTime, TimeToBase, ExchangeTime), as.numeric)) %>%
pivot_longer(
cols = c(PopTime, TimeToBase, ExchangeTime),
names_to = "Metric",
values_to = "Times"
) %>%
filter(!is.na(Times)) %>%
mutate(Metric = case_when(
Metric == "PopTime" ~ "Pop Time",
Metric == "TimeToBase" ~ "Throw Time",
Metric == "ExchangeTime" ~ "Exchange Time",
TRUE ~ NA
))
if (nrow(df_long) == 0) {
return(empty_plot("No 2B throw timing data"))
}
density_metrics <- df_long %>%
group_by(Metric) %>%
summarise(
n_points = sum(is.finite(Times)),
n_unique = dplyr::n_distinct(Times[is.finite(Times)]),
.groups = "drop"
) %>%
filter(n_points >= 2, n_unique >= 2)
density_df <- df_long %>%
semi_join(density_metrics, by = "Metric")
avg_times <- df_long %>%
group_by(Metric) %>%
summarize(
avg_time = mean(Times, na.rm = TRUE),
.groups = "drop"
)
dens_peaks <- df_long %>%
group_by(Metric) %>%
summarise(
max_y = safe_density_peak(Times),
.groups = "drop"
) %>%
mutate(max_y = dplyr::coalesce(max_y, 0.01))
avg_times <- avg_times %>%
left_join(dens_peaks, by = "Metric")
ggplot(df_long, aes(x = Times, fill = Metric)) +
geom_density(data = density_df, alpha = .6) +
geom_point(data = avg_times, aes(x = avg_time, y = 0.01, color = Metric), size = 3, shape = 21, stroke = 0.3) +
geom_segment(data = avg_times, aes(x = avg_time, xend = avg_time, y = 0, yend = Inf, color = Metric),
linetype = "dashed") +
theme_minimal() +
geom_label(
data = avg_times,
aes(x = avg_time, y = max_y, label = sprintf("%.2f", avg_time),
fill = Metric),
color = "white",
label.size = 0.2,
vjust = .5,
size = 5,
label.r = unit(0.15, "lines"),
show.legend = FALSE
) +
labs(
title = paste0(catcher, " Pop Time Distributions - 2B Throws"),
x = "Time (seconds)",
y = "Density",
color = "Metric"
) +
scale_x_continuous("Time (seconds)", limits = c(0, 3), breaks = seq(0, 3, by = .25)) +
scale_fill_manual(values = metric_colors) +
scale_color_manual(values = metric_colors) +
theme(
plot.title = element_text(hjust = 0.5, size = 12),
legend.position = c(0.99, 0.99),
legend.justification = c("right", "top"),
legend.background = element_rect(fill = alpha("white", 0.6), colour = NA),
legend.key = element_rect(fill = alpha("white", 0)),
panel.background = element_rect(fill = "white"),
axis.text.x = element_text(size = 12, face = "bold"),
axis.text.y = element_text(size = 12, face = "bold"),
legend.title = element_blank()
)
}
plot_catcher_throws <- function(data, catcher) {
df_long <- data %>%
filter(Catcher == catcher) %>%
drop_na(BasePositionX, BasePositionY, BasePositionZ) %>%
mutate(
base_angle = atan2(BasePositionX, BasePositionZ) * (180 / pi),
ThrowBase = case_when(
between(base_angle, 70, 110) ~ "2B",
between(base_angle, 111, 180) ~ "3B",
TRUE ~ NA_character_
)
) %>%
filter(ThrowBase %in% c("2B"))
df_long <- df_long %>%
mutate(ThrowSpeed = as.numeric(ThrowSpeed)) %>%
filter(is.finite(ThrowSpeed))
if (nrow(df_long) == 0) {
return(empty_plot("No 2B throw strength data"))
}
avg_speed <- mean(df_long$ThrowSpeed, na.rm = TRUE)
has_density <- nrow(df_long) >= 2 && dplyr::n_distinct(df_long$ThrowSpeed) >= 2
dens_peaks <- safe_density_peak(df_long$ThrowSpeed)
dens_peaks <- dplyr::coalesce(dens_peaks, 0.01)
ggplot(df_long, aes(x = ThrowSpeed)) +
{
if (has_density) geom_density(fill = "#EAAA00", alpha = 0.6)
} +
geom_point(aes(x = avg_speed, y = 0.01),
color = "#EAAA00", size = 3, shape = 21, fill = "#EAAA00", stroke = 0.6) +
geom_segment(aes(x = avg_speed, xend = avg_speed, y = 0, yend = Inf),
color = "#EAAA00", linetype = "dashed", size = 0.6) +
geom_label(
aes(x = avg_speed, y = dens_peaks, label = paste0(sprintf("%.1f", avg_speed), " MPH")),
fill = "#EAAA00",
color = "white",
fontface = "bold",
label.size = 0.2,
vjust = -0.5,
size = 5,
label.r = unit(0.15, "lines"),
show.legend = FALSE
) +
scale_x_continuous("Throw Speed (MPH)", limits = c(min(df_long$ThrowSpeed, na.rm = TRUE) - 3,
max(df_long$ThrowSpeed, na.rm = TRUE) + 3)) +
labs(
title = paste0(catcher, " Arm Strength Distribution - 2B Throws"),
x = "Time (seconds)",
y = "Density",
color = "Metric"
) +
theme_minimal() +
theme(
plot.title = element_text(hjust = 0.5, size = 12),
legend.position = "top",
panel.background = element_rect(fill = "white"),
axis.text.x = element_text(size = 12, face = "bold"),
axis.text.y = element_text(size = 12, face = "bold"),
legend.title = element_blank()
)
}
get_oaa_table <- function(df, player){
if (str_detect(player, "- CF")){
df %>%
drop_na(CF_Name, OAA_CF) %>%
filter(CF_Name == player) %>%
arrange(-catch_prob) %>%
mutate(HangTime = round(HangTime, 2),
OAA = round(is_catch - catch_probability, 2),
distance_to_ball = round(CF_distance_to_ball, 1),
angle_to_ball = round(CF_route_direction),
distance_from_home = round(CF_distance_from_home),
HangTime = paste0(HangTime, " Sec"),
distance_to_ball = paste0(distance_to_ball, " Ft"),
distance_from_home = paste0(distance_from_home, " Ft"),
is_catch = ifelse(is_catch ==1, "Yes", "No"),
angle_to_ball = paste0(angle_to_ball, "°"),
catch_probability = 100 * catch_probability,
catch_probability = paste0(catch_probability, "%"),
ExitSpeed = round(ExitSpeed),
ExitSpeed = paste0(ExitSpeed, " MPH"),
Distance = round(Distance),
Distance = paste0(Distance, " Ft"),
Bearing = round(Bearing),
Bearing = paste0(Bearing, "°"),
Angle = round(Angle),
Angle = paste0(Angle, "°")) %>%
select(Date, Inning, Batter, PlayResult, ExitSpeed, Angle, Bearing, Distance, HangTime, distance_to_ball, angle_to_ball, distance_from_home, is_catch, catch_probability, OAA) %>%
rename(`Hang Time` = HangTime, `Distance Needed` = distance_to_ball,
`Route Direction` = angle_to_ball,
`Distance From Home` = distance_from_home,
`Catch?` = is_catch, `Catch Probability` = catch_probability, EV = ExitSpeed, LA = Angle) %>%
arrange(OAA)
} else if (str_detect(player, "- LF")){
df %>%
drop_na(LF_Name, OAA_LF) %>%
filter(LF_Name == player) %>%
arrange(-catch_prob) %>%
mutate(HangTime = round(HangTime, 2),
OAA = round(is_catch - catch_probability, 2),
distance_to_ball = round(LF_distance_to_ball, 1),
angle_to_ball = round(LF_route_direction),
distance_from_home = round(LF_distance_from_home),
HangTime = paste0(HangTime, " Sec"),
distance_to_ball = paste0(distance_to_ball, " Ft"),
distance_from_home = paste0(distance_from_home, " Ft"),
is_catch = ifelse(is_catch ==1, "Yes", "No"),
angle_to_ball = paste0(angle_to_ball, "°"),
catch_probability = 100 * catch_probability,
catch_probability = paste0(catch_probability, "%"),
ExitSpeed = round(ExitSpeed),
ExitSpeed = paste0(ExitSpeed, " MPH"),
Distance = round(Distance),
Distance = paste0(Distance, " Ft"),
Bearing = round(Bearing),
Bearing = paste0(Bearing, "°"),
Angle = round(Angle),
Angle = paste0(Angle, "°")) %>%
select(Date, Inning, Batter, PlayResult, ExitSpeed, Angle, Bearing, Distance, HangTime, distance_to_ball, angle_to_ball, distance_from_home, is_catch, catch_probability, OAA) %>%
rename(`Hang Time` = HangTime, `Distance Needed` = distance_to_ball,
`Route Direction` = angle_to_ball,
`Distance From Home` = distance_from_home,
`Catch?` = is_catch, `Catch Probability` = catch_probability, EV = ExitSpeed, LA = Angle)
} else {
df %>%
drop_na(RF_Name, OAA_RF) %>%
filter(RF_Name == player) %>%
arrange(-catch_prob) %>%
mutate(HangTime = round(HangTime, 2),
OAA = round(is_catch - catch_probability, 2),
distance_to_ball = round(RF_distance_to_ball, 1),
angle_to_ball = round(RF_route_direction),
distance_from_home = round(RF_distance_from_home),
HangTime = paste0(HangTime, " Sec"),
distance_to_ball = paste0(distance_to_ball, " Ft"),
distance_from_home = paste0(distance_from_home, " Ft"),
is_catch = ifelse(is_catch ==1, "Yes", "No"),
angle_to_ball = paste0(angle_to_ball, "°"),
catch_probability = 100 * catch_probability,
catch_probability = paste0(catch_probability, "%"),
ExitSpeed = round(ExitSpeed),
ExitSpeed = paste0(ExitSpeed, " MPH"),
Distance = round(Distance),
Distance = paste0(Distance, " Ft"),
Bearing = round(Bearing),
Bearing = paste0(Bearing, "°"),
Angle = round(Angle),
Angle = paste0(Angle, "°")) %>%
select(Date, Inning, Batter, PlayResult, ExitSpeed, Angle, Bearing, Distance, HangTime, distance_to_ball, angle_to_ball, distance_from_home, is_catch, catch_probability, OAA) %>%
rename(`Hang Time` = HangTime, `Distance Needed` = distance_to_ball,
`Route Direction` = angle_to_ball,
`Distance From Home` = distance_from_home,
`Catch?` = is_catch, `Catch Probability` = catch_probability, EV = ExitSpeed, LA = Angle)
}
}
star_graph <- function(df, all_oaa_data, player){
if (str_detect(player, "- LF")){
player_data <- df %>%
filter(LF_Name == player, PlayResult != "Homerun") %>%
drop_na(OAA_LF) %>%
select(LF_distance_to_ball, HangTime, is_catch, catch_probability, OAA_LF) %>%
rename(distance_to_ball = LF_distance_to_ball)
OAA <- round(
sum(player_data$OAA_LF, na.rm = TRUE), 1)
} else if (str_detect(player, "- CF")){
player_data <- df %>%
filter(CF_Name == player, PlayResult != "Homerun") %>%
drop_na(OAA_CF) %>%
select(CF_distance_to_ball, HangTime, is_catch, catch_probability, OAA_CF) %>%
rename(distance_to_ball = CF_distance_to_ball)
OAA <- round(
sum(player_data$OAA_CF, na.rm = TRUE), 1)
} else{
player_data <- df %>%
filter(RF_Name == player, PlayResult != "Homerun") %>%
drop_na(OAA_RF) %>%
select(RF_distance_to_ball, HangTime, is_catch, catch_probability, OAA_RF) %>%
rename(distance_to_ball = RF_distance_to_ball)
OAA <- round(
sum(player_data$OAA_RF, na.rm = TRUE), 1)
}
all_oaa_data %>%
mutate(
distance_from_ball = pmin(LF_distance_to_ball, CF_distance_to_ball, RF_distance_to_ball)
) %>% drop_na(distance_from_ball) %>%
ggplot(aes(distance_from_ball, HangTime)) +
stat_summary_2d(aes(z = catch_probability), fun = mean, bins = 51) +
scale_fill_gradientn(
colors = c("white", "#ffffb2", "#feb24c", "#fc4e2a", "#800026"),
limits = c(0, 1),
breaks = c(0.01, 0.25, 0.5, 0.7, 0.9, 1),
labels = c("5 Star", "4 Star", "3 Star", "2 Star", "1 Star", " "),
name = "Catch Rating",
guide = guide_colorbar(barheight = unit(5, "in"))
) +
new_scale_fill() +
geom_point(
data = player_data %>% filter(catch_probability > 0, HangTime < 6, distance_to_ball < 140),
aes(x = distance_to_ball, y = HangTime, fill = factor(is_catch)),
shape = 21,
color = "black",
stroke = 1,
size = 4,
inherit.aes = FALSE,
alpha = 1
) +
scale_fill_manual(
name = "Actual Catch",
values = c("0" = "white", "1" = "green4"),
labels = c("Hit", "Catch"),
guide = guide_legend(override.aes = list(shape = 21, color = "black"))
) +
scale_x_continuous("Distance to Ball (ft)", limits = c(0, 140), breaks = seq(0, 140, by = 20)) +
scale_y_continuous("Hang Time (sec)", limits = c(2, 6)) +
theme_classic() +
ggtitle(paste0(OAA, " Outs Above Average")) +
theme(
legend.position = "right",
plot.title = element_text(hjust = .5, size = 20),
legend.title = element_blank(),
panel.grid.minor = element_blank(),
axis.title = element_text(size = 12),
axis.text = element_text(size = 10)
)
}
oaa_table <- function(df, player) {
if (str_detect(player, "- LF")) {
name_col <- sym("LF_Name")
oaa_col <- sym("OAA_LF")
} else if (str_detect(player, "- CF")) {
name_col <- sym("CF_Name")
oaa_col <- sym("OAA_CF")
} else {
name_col <- sym("RF_Name")
oaa_col <- sym("OAA_RF")
}
temp <- df %>%
mutate(
star_group = case_when(
catch_probability >= 0.90 ~ "1 Star",
catch_probability >= 0.70 ~ "2 Star",
catch_probability >= 0.50 ~ "3 Star",
catch_probability >= 0.25 ~ "4 Star",
catch_probability >= 0.01 ~ "5 Star"
)
) %>%
filter(!!name_col == player, catch_probability > 0) %>%
drop_na(!!oaa_col)
star_levels <- tibble(star_group = c("1 Star", "2 Star", "3 Star", "4 Star", "5 Star"))
star_summary <- temp %>%
group_by(star_group) %>%
summarise(
star_rating = paste0(
sum(is_catch, na.rm = TRUE), " / ", n(),
" (", round(100 * mean(is_catch, na.rm = TRUE), 1), "%)"
),
.groups = "drop"
) %>%
full_join(star_levels, by = "star_group") %>%
arrange(factor(star_group, levels = star_levels$star_group)) %>%
pivot_wider(names_from = star_group, values_from = star_rating)
total_summary <- temp %>%
summarise(
`Success Rate` = paste0(
sum(is_catch, na.rm = TRUE), " / ", n(),
" (", round(100 * mean(is_catch, na.rm = TRUE), 1), "%)"
)
)
total_est_summary <- temp %>%
summarise(
`X Success Rate` = paste0(
sum(catch_probability, na.rm = TRUE), " / ", n(),
" (", round(100 * mean(catch_probability, na.rm = TRUE), 1), "%)"
)
)
final_summary <- bind_cols(star_summary, total_summary, total_est_summary) %>%
mutate(OAA = round(sum(df[[as_string(oaa_col)]][df[[as_string(name_col)]] == player], na.rm = TRUE), 1)) %>%
select(OAA, `Success Rate`, `X Success Rate`, `1 Star`, `2 Star`, `3 Star`, `4 Star`, `5 Star`)
final_summary %>%
gt() %>%
wvu_gt_theme()
}
direction_oaa <- function(df, player) {
position <- sub(".*- ", "", player)
name_col <- paste0(position, "_Name")
oaa_col <- paste0("OAA_", position)
dir_col <- paste0(position, "_route_direction_full")
name_sym <- rlang::sym(name_col)
oaa_sym <- rlang::sym(oaa_col)
dir_sym <- rlang::sym(dir_col)
player_data <- df %>%
dplyr::filter(!!name_sym == player) %>%
tidyr::drop_na(!!dir_sym, !!oaa_sym) %>%
dplyr::mutate(direction = dplyr::case_when(
!!dir_sym >= 157.5 & !!dir_sym < 202.5 ~ "Back",
!!dir_sym >= 112.5 & !!dir_sym < 157.5 ~ "Back_Right",
!!dir_sym >= 67.5 & !!dir_sym < 122.5 ~ "Right",
!!dir_sym >= 22.5 & !!dir_sym < 67.5 ~ "In_Right",
!!dir_sym >= 337.5 | !!dir_sym < 22.5 ~ "In",
!!dir_sym >= 292.5 & !!dir_sym < 337.5 ~ "In_Left",
!!dir_sym >= 247.5 & !!dir_sym < 292.5 ~ "Left",
!!dir_sym >= 202.5 & !!dir_sym < 247.5 ~ "Back_Left"
)) %>%
dplyr::group_by(direction) %>%
dplyr::summarise(
Fielder = dplyr::first(!!name_sym),
OAA = 100 * base::mean(!!oaa_sym, na.rm = TRUE),
Plays = dplyr::n(),
.groups = "drop"
) %>%
dplyr::select(Fielder, direction, OAA, Plays)
clamp <- function(x) {
if (length(x) == 0) {
0
} else {
dplyr::if_else(!is.na(x) & (x < -7 | x > 7), pmax(-7, pmin(7, x)), x)
}
}
fielder_split <- data.frame(
group = 1,
In = clamp(player_data$OAA[player_data$direction == "In"]),
In_Right = clamp(player_data$OAA[player_data$direction == "In_Right"]),
Right = clamp(player_data$OAA[player_data$direction == "Right"]),
Back_Right = clamp(player_data$OAA[player_data$direction == "Back_Right"]),
Back = clamp(player_data$OAA[player_data$direction == "Back"]),
Back_Left = clamp(player_data$OAA[player_data$direction == "Back_Left"]),
Left = clamp(player_data$OAA[player_data$direction == "Left"]),
In_Left = clamp(player_data$OAA[player_data$direction == "In_Left"])
)
directions2 <- c("In", "In_Right", "Right", "Back_Right", "Back", "Back_Left", "Left", "In_Left")
axis_labels <- sapply(directions2, function(dir) {
plays <- player_data$Plays[player_data$direction == dir]
label <- gsub("_", " ", dir)
paste0(label, " (", ifelse(length(plays) == 0, 0, plays), ")")
})
radar_data <- fielder_split %>%
tidyr::pivot_longer(-group, names_to = "direction", values_to = "value") %>%
dplyr::mutate(
direction = factor(direction, levels = directions2),
value = dplyr::if_else(is.na(value), 0, value)
)
n_dirs <- length(directions2)
angles <- seq(0, 2 * pi, length.out = n_dirs + 1)[1:n_dirs]
radar_data <- radar_data %>%
dplyr::mutate(
angle = angles[as.numeric(direction)],
plot_value = value + 7,
x = plot_value * cos(angle - pi/2),
y = plot_value * sin(angle - pi/2)
)
# ---- FIX: build grid_df without rowwise/mutate(list(...)) so "angle" always exists ----
grid_levels <- c(0, 7, 14)
grid_df <- dplyr::bind_rows(lapply(grid_levels, function(r) {
a <- seq(0, 2*pi, length.out = 200)
data.frame(
r = r,
angle = a,
x = r * cos(a - pi/2),
y = r * sin(a - pi/2)
)
}))
axis_df <- data.frame(
direction = directions2,
label = axis_labels,
angle = angles
) %>%
dplyr::mutate(
x_end = 15 * cos(angle - pi/2),
y_end = 15 * sin(angle - pi/2),
x_lab = 18 * cos(angle - pi/2),
y_lab = 18 * sin(angle - pi/2)
)
ggplot2::ggplot() +
ggplot2::geom_path(
data = grid_df,
ggplot2::aes(x = x, y = y, group = r),
color = "grey80",
linetype = "dashed"
) +
ggplot2::geom_segment(
data = axis_df,
ggplot2::aes(x = 0, y = 0, xend = x_end, yend = y_end),
color = "grey60"
) +
ggplot2::geom_polygon(
data = radar_data,
ggplot2::aes(x = x, y = y, group = group),
fill = "#0d56ab",
alpha = 0.3
) +
ggplot2::geom_path(
data = radar_data,
ggplot2::aes(x = x, y = y, group = group),
color = "#0d56ab",
linewidth = 1
) +
ggplot2::geom_point(
data = radar_data,
ggplot2::aes(x = x, y = y),
color = "#0d56ab",
size = 3
) +
ggplot2::geom_text(
data = axis_df,
ggplot2::aes(x = x_lab, y = y_lab, label = label),
size = 3
) +
ggplot2::annotate("text", x = 0, y = c(0, 7, 14), label = c("-7", "0", "+7"), size = 2.5, color = "grey50") +
ggplot2::coord_fixed() +
ggplot2::labs(title = "OAA / 100 Plays by Direction\n(Fielder POV, Sample Size Labeled)") +
ggplot2::theme_void() +
ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
}
show_all_catches <- function(df, player){
if (str_detect(player, "- LF")){
df_filtered <- df %>%
filter(LF_Name == player, catch_probability > 0) %>%
drop_na(OAA_LF) %>%
mutate(star_group = case_when(
catch_probability >= 0.90 ~ "1 Star",
catch_probability >= 0.70 ~ "2 Star",
catch_probability >= 0.50 ~ "3 Star",
catch_probability >= 0.25 ~ "4 Star",
catch_probability >= 0.01 ~ "5 Star"
)) %>%
rename(distance_to_balll = LF_distance_to_ball)
avg_starting_pos <- df_filtered %>%
summarise(
avg_x = mean(LF_PositionAtReleaseX, na.rm = TRUE),
avg_y = mean(LF_PositionAtReleaseZ, na.rm = TRUE)
)
} else if (str_detect(player, "- CF")){
df_filtered <- df %>%
filter(CF_Name == player, catch_probability > 0, Distance >= 200) %>%
drop_na(OAA_CF) %>%
mutate(star_group = case_when(
catch_probability >= 0.90 ~ "1 Star",
catch_probability >= 0.70 ~ "2 Star",
catch_probability >= 0.50 ~ "3 Star",
catch_probability >= 0.25 ~ "4 Star",
catch_probability >= 0.01 ~ "5 Star"
)) %>%
rename(distance_to_balll = CF_distance_to_ball)
avg_starting_pos <- df_filtered %>%
summarise(
avg_x = mean(CF_PositionAtReleaseX, na.rm = TRUE),
avg_y = mean(CF_PositionAtReleaseZ, na.rm = TRUE)
)
} else{
df_filtered <- df %>%
filter(RF_Name == player, catch_probability > 0, Distance >= 200) %>%
drop_na(OAA_RF) %>%
mutate(star_group = case_when(
catch_probability >= 0.90 ~ "1 Star",
catch_probability >= 0.70 ~ "2 Star",
catch_probability >= 0.50 ~ "3 Star",
catch_probability >= 0.25 ~ "4 Star",
catch_probability >= 0.01 ~ "5 Star"
)) %>%
rename(distance_to_balll = RF_distance_to_ball)
avg_starting_pos <- df_filtered %>%
summarise(
avg_x = mean(RF_PositionAtReleaseX, na.rm = TRUE),
avg_y = mean(RF_PositionAtReleaseZ, na.rm = TRUE)
)
}
p <- ggplot() +
geom_segment(aes(x = 0, y = 0, xend = 318.1981, yend = 318.1981), color = "black") +
geom_segment(aes(x = 0, y = 0, xend = -318.1981, yend = 318.1981), color = "black") +
geom_segment(aes(x = 63.6396, y = 63.6396, xend = 0, yend = 127.279), color = "black") +
geom_segment(aes(x = -63.6396, y = 63.6396, xend = 0, yend = 127.279), color = "black") +
geom_curve(aes(x = 89.095, y = 89.095, xend = 0, yend = 160), curvature = 0.36, size = .5, color = "black") +
geom_curve(aes(x = -89.095, y = 89.095, xend = 0, yend = 160), curvature = -0.36, size = .5, color = "black") +
annotate("text", x = c(-155, 155), y = 135, label = "200", size = 3) +
annotate("text", x = c(-190, 190), y = 170, label = "250", size = 3) +
annotate("text", x = c(-227, 227), y = 205, label = "300", size = 3) +
annotate("text", x = c(-262, 262), y = 242, label = "350", size = 3) +
annotate("text", x = c(-297, 297), y = 277, label = "400", size = 3) +
annotate("text", x = c(-333, 333), y = 313, label = "450", size = 3) +
theme_void() +
geom_point(
data = df_filtered %>% mutate(is_catch = ifelse(is_catch == 1, 'Catch', "Hit")),
aes(
x = landing_x,
y = landing_y,
fill = factor(is_catch),
text = paste0(
"Date: ", Date, "<br>",
"Opportunity Time: ", round(HangTime, 2), " sec<br>",
"Distance Needed: ", round(distance_to_balll, 1), " ft<br>",
"Catch Probability: ", round(100 * catch_probability, 1), "%<br>",
"", star_group
)
),
color = "black",
shape = 21,
size = 2,
alpha = .6
) +
scale_fill_manual(
values = c("Hit" = "white", "Catch" = "green4"),
labels = c("Hit" = "Hit", "Catch" = "Catch"),
name = " "
) +
geom_point(data = avg_starting_pos, aes(x = avg_x, y = avg_y),
fill = "red", color = "black", size = 3, shape = 21) +
ylim(0, 420) +
xlim(-340, 340) +
coord_equal()
ggplotly(p, tooltip = "text") %>%
layout(hovermode = "closest")
}
star_graph_inf <- function(data, all_inf_oaa, player){
if (str_detect(player, "- SS")) {
player_data <- data %>%
filter(SS_Name == player) %>%
drop_na(OAA_SS) %>%
select(SS_shortest_distance_to_ball, SS_Bearing_diff, is_out, out_probability, OAA_SS, ExitSpeed) %>%
rename(distance_to_ball = SS_shortest_distance_to_ball) %>%
mutate(bearingdiff = abs(SS_Bearing_diff))
OAA <- round(sum(player_data$OAA_SS), 1)
} else if (str_detect(player, "- 1B")) {
player_data <- data %>%
filter(`1B_Name` == player) %>%
drop_na(OAA_1B) %>%
select(`1B_shortest_distance_to_ball`, `1B_Bearing_diff`, is_out, out_probability, OAA_1B, ExitSpeed) %>%
rename(distance_to_ball = `1B_shortest_distance_to_ball`) %>%
mutate(bearingdiff = abs(`1B_Bearing_diff`))
OAA <- round(sum(player_data$OAA_1B), 1)
} else if (str_detect(player, "- 2B")) {
player_data <- data %>%
filter(`2B_Name` == player) %>%
drop_na(OAA_2B) %>%
select(`2B_shortest_distance_to_ball`, `2B_Bearing_diff`, is_out, out_probability, OAA_2B, ExitSpeed) %>%
rename(distance_to_ball = `2B_shortest_distance_to_ball`) %>%
mutate(bearingdiff = abs(`2B_Bearing_diff`))
OAA <- round(sum(player_data$OAA_2B), 1)
} else if (str_detect(player, "- 3B")) {
player_data <- data %>%
filter(`3B_Name` == player) %>%
drop_na(OAA_3B) %>%
select(`3B_shortest_distance_to_ball`, `3B_Bearing_diff`, is_out, out_probability, OAA_3B, ExitSpeed) %>%
rename(distance_to_ball = `3B_shortest_distance_to_ball`) %>%
mutate(bearingdiff = abs(`3B_Bearing_diff`))
OAA <- round(sum(player_data$OAA_3B), 1)
}
all_inf_oaa %>%
mutate(
distance_from_ball = pmin(SS_shortest_distance_to_ball, `2B_shortest_distance_to_ball`,
`1B_shortest_distance_to_ball`, `3B_shortest_distance_to_ball`),
bearing_diff = abs(pmap_dbl(
list(`1B_Bearing_diff`, `2B_Bearing_diff`, `SS_Bearing_diff`, `3B_Bearing_diff`),
~ c(...) %>% .[which.min(abs(.))]
))
) %>% drop_na(distance_from_ball) %>%
ggplot(aes(ExitSpeed, bearing_diff)) +
stat_summary_2d(aes(z = out_probability), fun = mean, bins = 40) +
scale_fill_gradientn(
colors = c("white", "#ffffb2", "#feb24c", "#fc4e2a", "#800026"),
limits = c(0, 1),
breaks = c(0.01, 0.25, 0.5, 0.7, 0.9, 1),
labels = c("5 Star", "4 Star", "3 Star", "2 Star", "1 Star", " "),
name = "Catch Rating",
guide = guide_colorbar(barheight = unit(5, "in"))
) +
new_scale_fill() +
geom_point(
data = player_data %>% filter(out_probability > 0, bearingdiff < 15, distance_to_ball < 30),
aes(x = ExitSpeed, y = bearingdiff, fill = factor(is_out)),
shape = 21,
color = "black",
stroke = 1,
size = 4,
inherit.aes = FALSE,
alpha = 1
) +
scale_fill_manual(
name = "Actual Catch",
values = c("0" = "white", "1" = "green4"),
labels = c("Hit", "Catch"),
guide = guide_legend(override.aes = list(shape = 21, color = "black"))
) +
scale_x_continuous("Exit Velocity", limits = c(30, 110), breaks = seq(30, 110, by = 10)) +
scale_y_continuous("Angle From Ball", limits = c(0, 20)) +
theme_classic() +
ggtitle(paste0(OAA, " Outs Above Average")) +
theme(
legend.position = "right",
plot.title = element_text(hjust = .5, size = 20),
legend.title = element_blank(),
panel.grid.minor = element_blank(),
axis.title = element_text(size = 12),
axis.text = element_text(size = 10)
)
}
oaa_table_inf <- function(df, player) {
pos_map <- tibble::tibble(
suffix = c("LF", "CF", "RF", "SS", "1B", "2B", "3B"),
name_col = c("LF_Name", "CF_Name", "RF_Name", "SS_Name", "1B_Name", "2B_Name", "3B_Name"),
oaa_col = c("OAA_LF", "OAA_CF", "OAA_RF", "OAA_SS", "OAA_1B", "OAA_2B", "OAA_3B"),
bearing_col = c("LF_Bearing_diff", "CF_Bearing_diff", "RF_Bearing_diff",
"SS_Bearing_diff", "1B_Bearing_diff", "2B_Bearing_diff", "3B_Bearing_diff")
)
suffix <- stringr::str_extract(player, "(?<=-\\s).*")
if (!suffix %in% pos_map$suffix) {
stop("Unknown position in player string")
}
map_row <- pos_map[pos_map$suffix == suffix, ]
name_col <- sym(map_row$name_col)
oaa_col <- sym(map_row$oaa_col)
bearing_col <- sym(map_row$bearing_col)
temp <- df %>%
mutate(
star_group = case_when(
out_probability >= 0.90 ~ "1 Star",
out_probability >= 0.70 ~ "2 Star",
out_probability >= 0.50 ~ "3 Star",
out_probability >= 0.25 ~ "4 Star",
out_probability >= 0.01 ~ "5 Star"
)
) %>%
filter(!!name_col == player, out_probability > 0) %>%
drop_na(!!oaa_col)
# Ensure all star levels appear
star_levels <- tibble(star_group = c("1 Star", "2 Star", "3 Star", "4 Star", "5 Star"))
# Group by star rating
star_summary <- temp %>%
group_by(star_group) %>%
summarise(
star_rating = paste0(
sum(is_out, na.rm = TRUE), " / ", n(),
" (", round(100 * mean(is_out, na.rm = TRUE), 1), "%)"
),
.groups = "drop"
) %>%
full_join(star_levels, by = "star_group") %>%
arrange(factor(star_group, levels = star_levels$star_group)) %>%
pivot_wider(names_from = star_group, values_from = star_rating)
# Success rates
total_summary <- temp %>%
summarise(
`Success Rate` = paste0(
sum(is_out, na.rm = TRUE), " / ", n(),
" (", round(100 * mean(is_out, na.rm = TRUE), 1), "%)"
)
)
total_est_summary <- temp %>%
summarise(
`X Success Rate` = paste0(
sum(out_probability, na.rm = TRUE), " / ", n(),
" (", round(100 * mean(out_probability, na.rm = TRUE), 1), "%)"
)
)
direction_summary <- temp %>%
summarise(
`Lateral Towards 3B` = round(sum(if_else(!!bearing_col <= 0, !!oaa_col, 0), na.rm = TRUE), 1),
`Lateral Towards 1B` = round(sum(if_else(!!bearing_col >= 0, !!oaa_col, 0), na.rm = TRUE), 1)
)
final_summary <- bind_cols(
star_summary,
total_summary,
total_est_summary,
direction_summary
) %>%
mutate(OAA = round(sum(df[[as_string(oaa_col)]][df[[as_string(name_col)]] == player], na.rm = TRUE), 1)) %>%
select(OAA, `Success Rate`, `X Success Rate`,
`Lateral Towards 3B`, `Lateral Towards 1B`,
`1 Star`, `2 Star`, `3 Star`, `4 Star`, `5 Star`)
final_summary %>%
gt() %>%
wvu_gt_theme()
}
get_oaa_table_inf <- function(df, player) {
pos <- str_extract(player, "(?<=-\\s)(SS|1B|2B|3B)$")
name_col <- sym(paste0(pos, "_Name"))
oaa_col <- sym(paste0("OAA_", pos))
bearing_col <- sym(paste0(pos, "_Bearing_diff"))
dist_home_col <- sym(paste0(pos, "_distance_from_home"))
dist_ball_col <- sym(paste0(pos, "_shortest_distance_to_ball"))
df %>%
drop_na(!!name_col, !!oaa_col) %>%
filter(!!name_col == player, out_probability > 0) %>%
arrange(desc(out_probability)) %>%
mutate(
angle_to_ball = paste0(round(!!bearing_col), "°"),
distance_from_home = paste0(round(!!dist_home_col), " Ft"),
distance_to_ball = paste0(round(!!dist_ball_col, 1), " Ft"),
is_out = ifelse(is_out == 1, "Yes", "No"),
out_probability = paste0(round(100 * out_probability), "%"),
ExitSpeed = paste0(round(ExitSpeed), " MPH"),
Distance = paste0(round(Distance), " Ft"),
Bearing = paste0(round(Bearing), "°"),
Angle = paste0(round(Angle), "°")
) %>%
select(
Date, Inning, Batter, PlayResult, ExitSpeed, Angle, Bearing, angle_to_ball,
Distance, distance_to_ball, distance_from_home, is_out, out_probability, !!oaa_col
) %>%
rename(
`Shortest Distance Needed` = distance_to_ball,
`Route Direction` = angle_to_ball,
`Distance From Home` = distance_from_home,
`Out?` = is_out,
`Out Probability` = out_probability,
EV = ExitSpeed,
LA = Angle,
OAA = !!oaa_col
) %>%
mutate(OAA = round(OAA, 2)) %>%
arrange(OAA)
}
pitch_summary_bullpens <- function(data, player, width){
data <- data %>%
filter(Pitcher == player)
data <- data %>%
group_by(BatterSide) %>%
mutate(mean_RelSide = mean(RelSide, na.rm = TRUE)) %>%
ungroup() %>%
filter((abs(RelSide) - abs(mean_RelSide)) < .5)
types <- data %>%
group_by(TaggedPitchType) %>%
summarise(n = 100 * n() / nrow(data)) %>%
filter(n >= 1)
types <- unique(types$TaggedPitchType)
data <- data %>%
mutate(SpinAxis = SpinAxis + 180) %>%
mutate(SpinAxis = ifelse(SpinAxis > 360, SpinAxis - 360, SpinAxis))
spin <- data %>%
filter(TaggedPitchType %in% types) %>%
group_by(TaggedPitchType) %>%
summarise(axis = round(median(SpinAxis, na.rm = TRUE), 1)) %>%
rename(`Pitch Type` = TaggedPitchType) %>%
mutate(`Observed Axis` = angle_to_clock(axis))
measured_spin <- data %>%
mutate(SpinAxis3dTransverseAngle = SpinAxis3dTransverseAngle + 180) %>%
mutate(SpinAxis3dTransverseAngle = ifelse(SpinAxis3dTransverseAngle > 360, SpinAxis3dTransverseAngle - 360, SpinAxis3dTransverseAngle)) %>%
filter(TaggedPitchType %in% types) %>%
group_by(TaggedPitchType) %>% summarise(axis = round(median(SpinAxis3dTransverseAngle, na.rm = TRUE), 1)) %>%
rename(`Pitch Type` = TaggedPitchType) %>%
mutate(`Measured Axis` = angle_to_clock(axis))
pitcher_summary <- data %>%
filter(TaggedPitchType %in% types, TaggedPitchType != "Other") %>%
group_by(TaggedPitchType) %>%
summarise(P = n(),
Velo = sprintf("%.1f", mean(RelSpeed, na.rm = TRUE)),
Spin = sprintf("%.0f", mean(SpinRate, na.rm = TRUE)),
HB = sprintf("%.1f", mean(HorzBreak, na.rm = TRUE)),
iVB = sprintf("%.1f", mean(InducedVertBreak, na.rm = TRUE)),
Vaa = sprintf("%.1f", mean(VertApprAngle, na.rm = TRUE)),
Haa = sprintf("%.1f", mean(HorzApprAngle, na.rm = TRUE)),
Ext = sprintf("%.1f", mean(Extension, na.rm = TRUE)),
RelS = sprintf("%.1f", mean(RelSide, na.rm = TRUE)),
RelH = sprintf("%.1f", mean(RelHeight, na.rm = TRUE)),
`Zone%` = sprintf("%.1f", 100 * mean(in_zone, na.rm = TRUE)),
Eff = sprintf("%.0f", 100 * mean(SpinAxis3dSpinEfficiency, na.rm = TRUE)),
`Gyro°` = sprintf("%.0f", mean(SpinAxis3dLongitudinalAngle, na.rm = TRUE)),
Stuff = round(mean(stuff, na.rm = TRUE))
) %>%
rename(`Pitch Type` = TaggedPitchType) %>%
arrange(desc(P))
pitcher_summary <- pitcher_summary %>%
left_join(spin, by = "Pitch Type") %>%
left_join(measured_spin, by = "Pitch Type")
pitcher_summary <- pitcher_summary %>%
select(`Pitch Type`, P, Velo, iVB, HB, Spin,Eff, `Gyro°`, `Measured Axis`,`Observed Axis`
, RelH, RelS, Ext, Haa, Vaa, `Zone%`, Stuff) %>%
mutate(across(
-c(`Pitch Type`, `Observed Axis`, `Measured Axis`),
~ as.numeric(.)
))
pitcher_summary <- pitcher_summary %>%
gt() %>%
wvu_gt_theme(width = width) %>%
fmt_missing(columns = everything(), missing_text = "-") %>%
data_color(columns = `Zone%`, colors = make_color_fn(
quantile(summary_df_pitcher$`Zone%`, 0.1, na.rm = TRUE),
quantile(summary_df_pitcher$`Zone%`, 0.9, na.rm = TRUE))) %>%
data_color(columns = Stuff, colors = make_color_fn(80, 120)) %>%
data_color(columns = Eff, colors = make_color_fn(0, 100))
pitcher_summary <- pitcher_summary %>%
data_color(
columns = `Pitch Type`,
colors = scales::col_factor(
palette = pitch_colors,
domain = names(pitch_colors),
na.color = "white"
)
)
pitcher_summary
}