Sys.setenv(RETICULATE_PYTHON = "/usr/bin/python3")
library(shiny)
library(DT)
library(htmltools)
library(gt)
library(gtExtras)
library(plotly)
library(tidymodels)
library(xgboost)
library(arrow)
library(reticulate)
library(recipes)
library(httr)
library(fmsb)
library(dplyr)
library(tidyr)
library(stringr)
library(ggplot2)
library(scales)
# ============================================================
# READ IN DATA
# ============================================================
download_private_parquet <- function(repo_id, filename, max_retries = 3) {
url <- paste0("https://huggingface.co/datasets/", repo_id, "/resolve/main/", filename)
api_key <- Sys.getenv("HF_Token")
if (api_key == "") stop("API key is not set.")
for (attempt in 1:max_retries) {
tryCatch({
response <- GET(url, add_headers(Authorization = paste("Bearer", api_key)), timeout(60))
if (status_code(response) == 200) {
tmp <- tempfile(fileext = ".parquet")
writeBin(content(response, "raw"), tmp)
return(read_parquet(tmp))
} else warning(paste("Attempt", attempt, "failed with status:", status_code(response)))
}, error = function(e) {
warning(paste("Attempt", attempt, "failed:", e$message))
if (attempt < max_retries) Sys.sleep(2)
})
}
stop(paste("Failed to download dataset after", max_retries, "attempts"))
}
download_private_csv <- function(repo_id, filename, max_retries = 3) {
url <- paste0("https://huggingface.co/datasets/", repo_id, "/resolve/main/", filename)
api_key <- Sys.getenv("HF_Token")
if (api_key == "") stop("API key is not set.")
for (attempt in 1:max_retries) {
tryCatch({
response <- GET(url, add_headers(Authorization = paste("Bearer", api_key)), timeout(60))
if (status_code(response) == 200) {
tmp <- tempfile(fileext = ".csv")
writeBin(content(response, "raw"), tmp)
return(readr::read_csv(tmp, show_col_types = FALSE))
} else warning(paste("Attempt", attempt, "failed with status:", status_code(response)))
}, error = function(e) {
warning(paste("Attempt", attempt, "failed:", e$message))
if (attempt < max_retries) Sys.sleep(2)
})
}
stop(paste("Failed to download dataset after", max_retries, "attempts"))
}
clean_bind <- function(data) {
data <- data %>%
mutate(
Date = as.Date(Date),
across(any_of(c("Time","Tilt","UTCTime","LocalDateTime","UTCDateTime",
"CatchPositionX","CatchPositionY","CatchPositionZ",
"ThrowPositionX","ThrowPositionY","ThrowPositionZ",
"BasePositionX","BasePositionY","BasePositionZ")), as.character),
across(starts_with("ThrowTrajectory"), as.character),
across(ends_with("PositionAtReleaseX"), as.numeric),
across(ends_with("PositionAtReleaseZ"), as.numeric),
across(ends_with("_Id"), as.character))
if ("UTCDate" %in% names(data)) data$UTCDate <- as.Date(data$UTCDate)
if ("BatSpeed" %in% names(data)) data$BatSpeed <- as.numeric(data$BatSpeed)
if ("VerticalAttackAngle" %in% names(data)) data$VerticalAttackAngle <- as.numeric(data$VerticalAttackAngle)
if ("HorizontalAttackAngle" %in% names(data)) data$HorizontalAttackAngle <- as.numeric(data$HorizontalAttackAngle)
if ("PitchNo" %in% names(data)) data$PitchNo <- as.numeric(data$PitchNo)
if ("FHC" %in% names(data)) data$FHC <- as.numeric(data$FHC)
data
}
download_master_dataset <- function(repo_id, folder, token = Sys.getenv("HF_Token")) {
hf <- reticulate::import("huggingface_hub")
api <- hf$HfApi()
files <- api$list_repo_files(repo_id = repo_id, repo_type = "dataset", token = token)
pq_files <- files[grepl(paste0("^", folder, "/.*\\.parquet$"), files)]
if (length(pq_files) == 0) return(data.frame())
all_data <- lapply(pq_files, function(f) {
url <- paste0("https://huggingface.co/datasets/", repo_id, "/resolve/main/", f)
resp <- httr::GET(url, httr::add_headers(Authorization = paste("Bearer", token)))
if (httr::status_code(resp) == 200) {
tmp <- tempfile(fileext = ".parquet")
writeBin(httr::content(resp, as = "raw"), tmp)
d <- arrow::read_parquet(tmp); file.remove(tmp); d
} else NULL
})
combined <- bind_rows(Filter(Negate(is.null), lapply(all_data, clean_bind)))
if ("PitchUID" %in% names(combined)) combined <- combined %>% distinct(PitchUID, .keep_all = TRUE)
combined
}
download_private_xgb <- function(repo_id, filename, max_retries = 3) {
url <- paste0("https://huggingface.co/datasets/", repo_id, "/resolve/main/", filename)
api_key <- Sys.getenv("HF_Token")
if (api_key == "") stop("API key is not set.")
for (attempt in 1:max_retries) {
tryCatch({
response <- GET(url, add_headers(Authorization = paste("Bearer", api_key)), timeout(60))
if (status_code(response) == 200) {
tmp <- tempfile(fileext = ".json")
writeBin(content(response, "raw"), tmp)
return(xgb.load(tmp))
} else warning(paste("Attempt", attempt, "failed with status:", status_code(response)))
}, error = function(e) {
warning(paste("Attempt", attempt, "failed:", e$message))
if (attempt < max_retries) Sys.sleep(2)
})
}
stop(paste("Failed to download dataset after", max_retries, "attempts"))
}
download_private_rds <- function(repo_id, filename, max_retries = 3) {
url <- paste0("https://huggingface.co/datasets/", repo_id, "/resolve/main/", filename)
api_key <- Sys.getenv("HF_Token")
if (api_key == "") stop("API key is not set.")
for (attempt in 1:max_retries) {
tryCatch({
response <- GET(url, add_headers(Authorization = paste("Bearer", api_key)), timeout(60))
if (status_code(response) == 200) {
tmp <- tempfile(fileext = ".rds")
writeBin(content(response, "raw"), tmp)
return(readRDS(tmp))
} else warning(paste("Attempt", attempt, "failed:", e$message))
}, error = function(e) {
warning(paste("Attempt", attempt, "failed:", e$message))
if (attempt < max_retries) Sys.sleep(2)
})
}
stop(paste("Failed to download dataset after", max_retries, "attempts"))
}
# Load models & recipes
IF_OAA_recipe <- download_private_rds("CoastalBaseball/DefenseAppDataset", "new_if_oaa_recipe.rds")
IF_OAA_model <- download_private_xgb("CoastalBaseball/DefenseAppDataset", "new_if_oaa_model.json")
OF_OAA_recipe <- download_private_rds("CoastalBaseball/DefenseAppDataset", "new_oaa_recipe.rds")
OF_OAA_model <- download_private_xgb("CoastalBaseball/DefenseAppDataset", "new_oaa_model.json")
# Load pre-computed 2025 data
IF_OAA_25 <- download_private_parquet("CoastalBaseball/DefenseAppDataset", "IF_OAA_DATA.parquet") %>%
mutate(obs_player_name = str_replace_all(obs_player_name, "(\\w+), (\\w+)", "\\2 \\1"),
play_pred = as.numeric(as.character(play_pred)),
Date = as.Date(Date),
Inning = as.numeric(Inning))
if ("obs_player_bearing_diff" %in% names(IF_OAA_25)) {
IF_OAA_25$obs_player_direction_diff <- IF_OAA_25$obs_player_bearing_diff
}
OF_OAA_25 <- as.data.frame(download_private_parquet("CoastalBaseball/DefenseAppDataset", "CC_OAA25.parquet")) %>%
mutate(obs_player = str_replace_all(obs_player, "(\\w+), (\\w+)", "\\2 \\1"),
pred_catch = as.numeric(as.character(pred_catch)),
Date = as.Date(Date),
Inning = as.numeric(Inning))
# Load 2026 raw data
spring26_pbp <- download_master_dataset("CoastalBaseball/2026MasterDataset", "pbp")
spring26_pos <- download_master_dataset("CoastalBaseball/2026MasterDataset", "pos")
spring26_ncaa <- download_master_dataset("CoastalBaseball/2026MasterDataset", "ncaa_pbp")
college_join <- download_private_csv("CoastalBaseball/DefenseAppDataset", "college_join.csv")
# Load Catcher 2026 data
Catcher2026 <- read_parquet("Catcher2026.parquet")
Catcher2026 <- Catcher2026 %>%
mutate(
Date = as.Date(Date),
across(any_of(c("CatchPositionX","CatchPositionY","CatchPositionZ",
"ThrowPositionX","ThrowPositionY","ThrowPositionZ",
"BasePositionX","BasePositionY","BasePositionZ")), as.numeric),
across(starts_with("ThrowTrajectory"), as.numeric),
across(any_of(c("ThrowSpeed","PopTime","ExchangeTime","TimeToBase")), as.numeric),
across(any_of(c("x0","y0","z0","vx0","vy0","vz0","ax0","ay0","az0")), as.numeric),
Notes = as.character(Notes),
is_swing = as.numeric(is_swing),
in_zone = as.numeric(in_zone)
)
# Classify framing: Strike Added / Strike Lost
# Use plate location geometry (converted to feet) to determine zone status
# Zone: |PlateLocSide/12| <= 0.83083 AND PlateLocHeight/12 between 1.5 and 3.3775
CALLED_STRIKE <- c("StrikeCalled","Called Strike","strike_called")
CALLED_BALL <- c("BallCalled","Ball","ball_called","BallinDirt","BallIntentional",
"HitByPitch","AutomaticBall")
Catcher2026 <- Catcher2026 %>%
mutate(
pls_ft = as.numeric(PlateLocSide) / 12,
plh_ft = as.numeric(PlateLocHeight) / 12,
loc_in_zone = abs(pls_ft) <= 0.83083 & plh_ft >= 1.5 & plh_ft <= 3.3775,
frame = case_when(
is.na(pls_ft) | is.na(plh_ft) ~ NA_character_,
!loc_in_zone & PitchCall %in% CALLED_STRIKE ~ "Strike Added",
loc_in_zone & PitchCall %in% CALLED_BALL ~ "Strike Lost",
TRUE ~ NA_character_
),
frame_numeric = case_when(
frame == "Strike Added" ~ 1,
frame == "Strike Lost" ~ -1,
TRUE ~ NA_real_
)
) %>%
dplyr::select(-pls_ft, -plh_ft, -loc_in_zone)
# ============================================================
# PREPARE DEFENSE DATA
# ============================================================
join_pbp_pos <- function(pbp_df, pos_df) {
df <- left_join(pbp_df,
pos_df %>%
rename(pos_PitchNo = PitchNo, pos_PlayID = PlayID,
pos_PlayResult = PlayResult, pos_PitchCall = PitchCall) %>%
dplyr::select(-any_of(c("Date","Time","PitcherTeam","BatterTeam",
"GameUID","UTCDate","UTCTime","LocalDateTime","UTCDateTime"))),
by = "PitchUID") %>%
group_by(GameUID, PitcherTeam) %>%
fill(all_of(ends_with("_Name")), .direction = "downup") %>%
ungroup() %>%
drop_na("LF_Name")
df
}
prefixes <- c("St\\.", "Mc", "De", "Di", "Van", "Von")
join_pbppos_ncaa <- function(trackman_df, ncaa_df) {
trackman_df <- trackman_df %>%
mutate(Inning = as.character(Inning),
Date = as.character(Date))
ncaa_df <- ncaa_df %>%
mutate(inning = as.character(inning),
Date = as.character(game_date))
trackman_df <- trackman_df %>%
mutate(HomeTeam = ifelse(HomeTeam == "AUB_PRC", "AUB_TIG", HomeTeam),
HomeTeam = ifelse(HomeTeam == "WVN_MN2", "WES_MOU", HomeTeam),
Date = as.character(Date))
trackman_df <- trackman_df %>%
mutate(
last_name = if_else(
str_detect(Batter, paste0("\\b(", paste(prefixes, collapse = "|"), ")\\s+[A-Z][a-z]+$")),
str_extract(Batter, paste0("(", paste(prefixes, collapse = "|"), ")\\s+[A-Z][a-z]+$")),
str_extract(Batter, "[^ ]+$")),
last_name = tolower(last_name))
ncaa_df <- ncaa_df %>%
dplyr::select(., -any_of(c("HomeTeam", "AwayTeam"))) %>%
left_join(college_join, by = "home_team") %>%
left_join(college_join %>% rename(away_team = home_team, AwayTeam = HomeTeam), by = "away_team")
ncaa_df <- ncaa_df %>%
filter(sub_fl == "0") %>%
filter(!str_detect(tmp_text, "wild pitch|passed ball|stole|caught stealing|picked off|No play|challenge|Batting Starts|Batting ends|Ejected|confirmed|balk|Challenged|overturned|upheld|suspended|resumed|challenged|challenge,")) %>%
filter(!str_starts(tmp_text, "NA")) %>%
mutate(
tmp_text = str_trim(tmp_text, side = "left"),
last_name_pbp = str_extract(tmp_text, "^[^ ,]+(?:\\s[A-Z][a-z]+)?"),
last_name_pbp = str_replace(last_name_pbp, "^[a-zA-Z]\\.?\\s+", ""),
last_name_pbp = tolower(last_name_pbp),
game_date = as.Date(game_date)) %>%
drop_na(bat_text)
hits_df <- left_join(trackman_df,
ncaa_df %>%
dplyr::select(-BatterTeam, -PitcherTeam) %>%
distinct(last_name_pbp, inning, Date, HomeTeam, AwayTeam, .keep_all = TRUE),
by = c("last_name" = "last_name_pbp", "Inning" = "inning", "Date", "HomeTeam", "AwayTeam"),
relationship = "many-to-one") %>%
distinct(PitchUID, .keep_all = TRUE) %>%
drop_na(away_score_after)
hits_df
}
of_oaa_setup <- function(data) {
d <- data %>%
filter(TaggedHitType %in% c("FlyBall","LineDrive","Popup") |
AutoHitType %in% c("FlyBall","LineDrive","Popup")) %>%
mutate(
across(ends_with("PositionAtReleaseX"), as.numeric),
across(ends_with("PositionAtReleaseZ"), as.numeric),
rad = Bearing * pi/180,
x_pos = Distance * cos(rad), z_pos = Distance * sin(rad),
dist_RF = sqrt((x_pos - RF_PositionAtReleaseX)^2 + (z_pos - RF_PositionAtReleaseZ)^2),
dist_CF = sqrt((x_pos - CF_PositionAtReleaseX)^2 + (z_pos - CF_PositionAtReleaseZ)^2),
dist_LF = sqrt((x_pos - LF_PositionAtReleaseX)^2 + (z_pos - LF_PositionAtReleaseZ)^2),
hit_location = case_when(
dist_CF <= dist_RF & dist_CF <= dist_LF ~ "CF",
dist_RF <= dist_CF & dist_RF <= dist_LF ~ "RF",
dist_LF <= dist_CF & dist_LF <= dist_RF ~ "LF", TRUE ~ NA_character_),
closest_pos_dist = case_when(
hit_location == "CF" ~ dist_CF, hit_location == "RF" ~ dist_RF,
hit_location == "LF" ~ dist_LF, TRUE ~ NA_real_),
angle_from_home = case_when(
hit_location == "CF" ~ atan2(z_pos - CF_PositionAtReleaseZ, x_pos - CF_PositionAtReleaseX) * 180/pi,
hit_location == "RF" ~ atan2(z_pos - RF_PositionAtReleaseZ, x_pos - RF_PositionAtReleaseX) * 180/pi,
hit_location == "LF" ~ atan2(z_pos - LF_PositionAtReleaseZ, x_pos - LF_PositionAtReleaseX) * 180/pi,
TRUE ~ NA_real_),
angle_from_home = case_when(
(angle_from_home > 0 & angle_from_home <= 180) ~ abs(angle_from_home - 180),
(angle_from_home >= -180 & angle_from_home <= 0) ~ -(angle_from_home + 180),
TRUE ~ NA_real_),
obs_player = case_when(
hit_location == "CF" ~ CF_Name, hit_location == "LF" ~ LF_Name,
hit_location == "RF" ~ RF_Name, TRUE ~ NA_character_),
success_ind = as.numeric(OutsOnPlay > 0),
feet_per_second = closest_pos_dist / HangTime) %>%
filter(feet_per_second <= 30, closest_pos_dist < 200,
event_type != "Home Run")
d <- d %>% mutate(success_ind = factor(success_ind))
processed <- bake(OF_OAA_recipe, new_data = d) %>%
dplyr::select(-any_of("success_ind")) %>%
mutate(across(where(is.factor), as.numeric), across(where(is.character), as.numeric))
dmat <- xgb.DMatrix(data = as.matrix(processed))
probs <- predict(OF_OAA_model, dmat)
d <- cbind(d, catch_prob = probs)
d %>% mutate(
obs_player = str_replace_all(obs_player, "(\\w+), (\\w+)", "\\2 \\1"),
catch_prob = 1 - catch_prob,
pred_catch = ifelse(catch_prob >= .5, 1, 0),
OAA = (as.numeric(success_ind) - 1) - catch_prob) %>%
dplyr::select(OAA, success_ind, catch_prob, pred_catch, closest_pos_dist,
x_pos, z_pos, Distance, Bearing, HangTime, angle_from_home,
obs_player, feet_per_second, hit_location, Date,
Inning, Batter, Pitcher, HomeTeam, AwayTeam,
PitcherTeam, ends_with("AtReleaseX"), ends_with("AtReleaseZ"))
}
if_oaa_setup <- function(data) {
d <- data %>%
filter(TaggedHitType == "GroundBall") %>%
mutate(across(starts_with("HitTr"), as.numeric)) %>%
filter(!is.na(Direction)) %>%
mutate(
extract_raw = case_when(
str_detect(bat_text, "grounded out,") ~
str_extract(bat_text, "(?<=,\\s)\\w+(?=\\s+to\\s+\\w+)"),
TRUE ~ str_extract(bat_text, "(?<=\\b(?:to|down the|through the|up the|by)\\s)\\w+(?:\\s\\w+)?")),
extracted_word = case_when(
str_detect(extract_raw, "^\\w{2}(\\s|$)") ~ word(extract_raw, 1), TRUE ~ extract_raw),
bearing_1b = atan2(`1B_PositionAtReleaseZ`, `1B_PositionAtReleaseX`) * 180/pi,
bearing_1b = case_when(bearing_1b <= -180 ~ bearing_1b+360, bearing_1b > 180 ~ bearing_1b-360, TRUE ~ bearing_1b),
bearing_2b = atan2(`2B_PositionAtReleaseZ`, `2B_PositionAtReleaseX`) * 180/pi,
bearing_2b = case_when(bearing_2b <= -180 ~ bearing_2b+360, bearing_2b > 180 ~ bearing_2b-360, TRUE ~ bearing_2b),
bearing_3b = atan2(`3B_PositionAtReleaseZ`, `3B_PositionAtReleaseX`) * 180/pi,
bearing_3b = case_when(bearing_3b <= -180 ~ bearing_3b+360, bearing_3b > 180 ~ bearing_3b-360, TRUE ~ bearing_3b),
bearing_ss = atan2(`SS_PositionAtReleaseZ`, `SS_PositionAtReleaseX`) * 180/pi,
bearing_ss = case_when(bearing_ss <= -180 ~ bearing_ss+360, bearing_ss > 180 ~ bearing_ss-360, TRUE ~ bearing_ss),
diff_1b = abs(Bearing - bearing_1b), diff_2b = abs(Bearing - bearing_2b),
diff_3b = abs(Bearing - bearing_3b), diff_ss = abs(Bearing - bearing_ss)) %>%
filter(!str_detect(bat_text, "interference|homered")) %>%
filter(!(extracted_word %in% c("p","p unassisted","pitcher","c"))) %>%
mutate(
obs_player = case_when(
extracted_word %in% c("1b","first base") ~ "1B", extracted_word %in% c("2b","second base") ~ "2B",
extracted_word %in% c("3b","third base") ~ "3B", extracted_word %in% c("SS","shortstop") ~ "SS",
pmin(diff_1b,diff_2b,diff_3b,diff_ss) == diff_1b ~ "1B",
pmin(diff_1b,diff_2b,diff_3b,diff_ss) == diff_2b ~ "2B",
pmin(diff_1b,diff_2b,diff_3b,diff_ss) == diff_3b ~ "3B",
pmin(diff_1b,diff_2b,diff_3b,diff_ss) == diff_ss ~ "SS", TRUE ~ NA),
obs_player_name = case_when(
obs_player == "SS" ~ SS_Name, obs_player == "2B" ~ `2B_Name`,
obs_player == "3B" ~ `3B_Name`, obs_player == "1B" ~ `1B_Name`, TRUE ~ NA),
obs_player_z = case_when(obs_player=="1B"~`1B_PositionAtReleaseZ`,obs_player=="2B"~`2B_PositionAtReleaseZ`,
obs_player=="3B"~`3B_PositionAtReleaseZ`,obs_player=="SS"~`SS_PositionAtReleaseZ`),
obs_player_x = case_when(obs_player=="1B"~`1B_PositionAtReleaseX`,obs_player=="2B"~`2B_PositionAtReleaseX`,
obs_player=="3B"~`3B_PositionAtReleaseX`,obs_player=="SS"~`SS_PositionAtReleaseX`),
obs_player_bearing = case_when(obs_player=="1B"~bearing_1b,obs_player=="2B"~bearing_2b,
obs_player=="3B"~bearing_3b,obs_player=="SS"~bearing_ss),
obs_player_direction_diff = obs_player_bearing - Direction,
obs_player_bearing_diff = obs_player_direction_diff,
dist_from_first = sqrt((obs_player_z - 63.64)^2 + (obs_player_x + 63.64)^2),
dist_from_second = sqrt((obs_player_z)^2 + (obs_player_x - 127.28)^2),
dist_from_third = sqrt((obs_player_z + 63.64)^2 + (obs_player_x - 63.64)^2),
dist_from_lead_base = case_when(!is.na(r1_name) & Outs < 2 ~ dist_from_second, TRUE ~ dist_from_first),
success_ind = case_when(
pos_PlayResult %in% c("Single","Double","Error","Sacrifice","Triple","HomeRun") ~ 0,
str_detect(bat_text, "singled|doubled|tripled") ~ 0,
outs_on_play > 0 ~ 1, TRUE ~ 1),
player_angle_rad = atan2(obs_player_x, obs_player_z)) %>%
filter(!is.na(obs_player))
processed <- bake(IF_OAA_recipe, new_data = d) %>%
dplyr::select(-any_of("success_ind")) %>%
mutate(across(where(is.factor), as.numeric), across(where(is.character), as.numeric))
dmat <- xgb.DMatrix(data = as.matrix(processed))
probs <- predict(IF_OAA_model, dmat)
d <- cbind(d, play_prob = probs)
d %>% mutate(
obs_player_name = str_replace_all(obs_player_name, "(\\w+), (\\w+)", "\\2 \\1"),
Date = as.Date(Date),
Inning = as.numeric(Inning),
play_prob = 1 - play_prob,
play_pred = ifelse(play_prob >= .5, 1, 0),
OAA = (as.numeric(success_ind)) - play_prob) %>%
dplyr::select(obs_player_name, obs_player, success_ind, play_prob, play_pred, OAA,
obs_player_direction_diff, obs_player_direction_diff, obs_player_bearing,
obs_player_x, obs_player_z,
HangTime, Distance, Bearing, Direction, ExitSpeed, Angle,
dist_from_lead_base, player_angle_rad,
Date, Pitcher, Inning, Batter, HomeTeam, AwayTeam,
PitcherTeam, ends_with("AtReleaseX"), ends_with("AtReleaseZ"),
everything())
}
# Prepare data
pbp_pos_spring26 <- join_pbp_pos(spring26_pbp, spring26_pos)
pbp_pos_ncaa_spring26 <- join_pbppos_ncaa(pbp_pos_spring26, spring26_ncaa)
OF_OAA_26 <- of_oaa_setup(pbp_pos_spring26)
IF_OAA_26 <- if_oaa_setup(pbp_pos_ncaa_spring26)
# Defensive positioning data
def_pos_data <- pbp_pos_ncaa_spring26
# ============================================================
# LOAD BASERUNNING HUSTLE DATA
# ============================================================
baserunning_raw <- read.csv("Coastal Carolina Baseball Hustle% 2025(Sheet1).csv",
stringsAsFactors = FALSE, check.names = FALSE)
baserunning_raw <- baserunning_raw[, !grepl("^$|^Unnamed", names(baserunning_raw))]
colnames(baserunning_raw) <- c("Player", "MaxSpeedRaw", "AvgSpeedRaw", "HustlePctRaw",
"Speed75Raw", "Speed80Raw", "Speed90Raw", "NoHR_FlyoutRaw")
baserunning <- baserunning_raw %>%
mutate(across(where(is.character), str_trim)) %>%
mutate(
MaxSpeed = as.numeric(str_remove(MaxSpeedRaw, " MPH")),
AvgSpeed = as.numeric(str_remove(AvgSpeedRaw, " MPH")),
HustlePct = as.numeric(str_remove(HustlePctRaw, "%")),
Speed75 = as.numeric(str_remove(Speed75Raw, " MPH")),
Speed80 = as.numeric(str_remove(Speed80Raw, " MPH")),
Speed90 = as.numeric(str_remove(Speed90Raw, " MPH")),
NoHR_Flyout = as.numeric(str_remove(NoHR_FlyoutRaw, "%"))
) %>%
dplyr::select(Player, MaxSpeed, AvgSpeed, HustlePct, Speed75, Speed80, Speed90, NoHR_Flyout) %>%
filter(!is.na(Player) & Player != "")
# ============================================================
# PITCH COLORS & CATCHER HELPERS
# ============================================================
pitch_colors <- c(
"Fastball"="#3465cb","Four-Seam"="#3465cb","FourSeamFastBall"="#3465cb",
"4-Seam Fastball"="#3465cb","FF"="#3465cb",
"Sinker"="#e5e501","TwoSeamFastBall"="#e5e501","Two-Seam"="#e5e501",
"2-Seam Fastball"="#e5e501","SI"="#e5e501",
"Slider"="#65aa02","SL"="#65aa02",
"Sweeper"="#dc4476","SW"="#dc4476",
"Curveball"="#d73813","CB"="#d73813","Knuckle Curve"="#d73813","KC"="#d73813",
"ChangeUp"="#980099","Changeup"="#980099","CH"="#980099",
"Splitter"="#23a999","FS"="#23a999","SP"="#23a999",
"Cutter"="#ff9903","FC"="#ff9903",
"Slurve"="#9370DB","Other"="gray50")
throw_color_map <- c('2B Out'='#339a1d','2B Safe'='red','3B Out'='#1a5d1a','3B Safe'='#ff6b6b')
.classify_block_type <- function(notes) {
dplyr::case_when(
grepl("^block$", notes, ignore.case = TRUE) ~ "Block",
grepl("pbwp|pb/wp|pb\\+wp|wild\\s*pitch|passed\\s*ball|wp|pb", notes, ignore.case = TRUE) ~ "PB/WP",
grepl("block", notes, ignore.case = TRUE) ~ "Block",
TRUE ~ "Block")
}
.is_block_event <- function(notes) {
grepl("block|pbwp|pb/wp|pb\\+wp|wild\\s*pitch|passed\\s*ball|\\bwp\\b|\\bpb\\b", notes, ignore.case = TRUE)
}
.is_throw_event <- function(notes) {
grepl("2b\\s*(out|safe)|3b\\s*(out|safe)", notes, ignore.case = TRUE)
}
.extract_throw_label <- function(notes) {
n <- tolower(trimws(notes))
dplyr::case_when(
grepl("2b\\s*out", n) ~ "2B Out",
grepl("2b\\s*safe", n) ~ "2B Safe",
grepl("3b\\s*out", n) ~ "3B Out",
grepl("3b\\s*safe", n) ~ "3B Safe",
TRUE ~ NA_character_
)
}
catcher_compute_ground_intersection <- function(df) {
df %>% mutate(
.a = 0.5 * az0, .b = vz0, .c = z0,
.disc = .b^2 - 4 * .a * .c,
.t1 = ifelse(.disc >= 0, (-.b + sqrt(pmax(.disc,0)))/(2*.a), NA_real_),
.t2 = ifelse(.disc >= 0, (-.b - sqrt(pmax(.disc,0)))/(2*.a), NA_real_),
t_ground = pmin(ifelse(.t1>0,.t1,Inf), ifelse(.t2>0,.t2,Inf)),
t_ground = ifelse(is.finite(t_ground), t_ground, NA_real_),
x_ground = x0 + vx0*t_ground + 0.5*ax0*t_ground^2,
y_ground = y0 + vy0*t_ground + 0.5*ay0*t_ground^2,
in_dirt = !is.na(t_ground)
) %>% dplyr::select(-starts_with(".a"), -starts_with(".b"), -starts_with(".c"),
-starts_with(".disc"), -starts_with(".t1"), -starts_with(".t2"))
}
# Helper: draw strike zone using geom_segment (plotly-compatible, no geom_rect)
sz_segments <- function() {
list(
geom_segment(aes(x=-.83083,xend=.83083,y=1.5,yend=1.5), color="black", linewidth=.7, inherit.aes=FALSE),
geom_segment(aes(x=-.83083,xend=.83083,y=3.3775,yend=3.3775), color="black", linewidth=.7, inherit.aes=FALSE),
geom_segment(aes(x=-.83083,xend=-.83083,y=1.5,yend=3.3775), color="black", linewidth=.7, inherit.aes=FALSE),
geom_segment(aes(x=.83083,xend=.83083,y=1.5,yend=3.3775), color="black", linewidth=.7, inherit.aes=FALSE)
)
}
bz_segments <- function() {
list(
geom_segment(aes(x=-.9975,xend=.9975,y=1.3775,yend=1.3775), color="gray50", linewidth=.5, linetype="dotted", inherit.aes=FALSE),
geom_segment(aes(x=-.9975,xend=.9975,y=3.5,yend=3.5), color="gray50", linewidth=.5, linetype="dotted", inherit.aes=FALSE),
geom_segment(aes(x=-.9975,xend=-.9975,y=1.3775,yend=3.5), color="gray50", linewidth=.5, linetype="dotted", inherit.aes=FALSE),
geom_segment(aes(x=.9975,xend=.9975,y=1.3775,yend=3.5), color="gray50", linewidth=.5, linetype="dotted", inherit.aes=FALSE)
)
}
hp_polygon <- data.frame(x=c(-.60,.60,.60,0,-.60), y=c(.15,.15,.27,.42,.27))
# ============================================================
# FIELD DRAWING HELPERS
# ============================================================
make_curve_segments <- function(x_start, y_start, x_end, y_end, curvature = 0.3, n = 40) {
t <- seq(0, 1, length.out = n)
cx <- (x_start + x_end)/2 + curvature * (y_end - y_start)
cy <- (y_start + y_end)/2 - curvature * (x_end - x_start)
x <- (1-t)^2*x_start + 2*(1-t)*t*cx + t^2*x_end
y <- (1-t)^2*y_start + 2*(1-t)*t*cy + t^2*y_end
i <- seq_len(n-1)
tibble(x = x[i], y = y[i], xend = x[i+1], yend = y[i+1])
}
curve1 <- make_curve_segments(89.095, 89.095, -1, 160, curvature = 0.36, n = 60)
curve2 <- make_curve_segments(-89.095, 89.095, 1, 160, curvature = -0.36, n = 60)
curve3 <- make_curve_segments(233.35, 233.35, -10, 410, curvature = 0.36, n = 60)
curve4 <- make_curve_segments(-233.35, 233.35, 10, 410, curvature = -0.36, n = 60)
# ============================================================
# VISUALIZATION FUNCTIONS (OF/IF)
# ============================================================
star_graph <- function(player, position, data) {
if (position %in% c("RF","CF","LF")) {
pd <- data %>% filter(obs_player == player, hit_location == position)
} else {
pd <- data %>% filter(obs_player == player) %>% mutate(hit_location = "All")
}
pd <- pd %>% mutate(star_group = case_when(
catch_prob >= 0.90 ~ "1 Star", catch_prob >= 0.70 ~ "2 Star",
catch_prob >= 0.50 ~ "3 Star", catch_prob >= 0.25 ~ "4 Star",
catch_prob >= 0.00000001 ~ "5 Star"))
OAA <- round(sum(pd$OAA, na.rm = TRUE), 1)
n_plays <- nrow(pd)
exp_s <- round(sum(pd$catch_prob, na.rm = TRUE), 1)
act_s <- sum(as.numeric(as.character(pd$success_ind)), na.rm = TRUE)
p <- ggplot(data, aes(closest_pos_dist, HangTime)) +
stat_summary_2d(aes(z = catch_prob), 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"))) +
scale_x_continuous("Distance to Ball (ft)", limits = c(0,140), breaks = seq(0,140,20)) +
scale_y_continuous("Hang Time (sec)", limits = c(2,6)) +
theme_classic() +
ggtitle(paste0(player, " - ", position, " (", OAA, " OAA)")) +
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))
pt_colors <- ifelse(pd$success_ind == 1, "green4", "white")
suppressWarnings({
ggplotly(p, tooltip = NULL) %>%
add_trace(data = pd, x = ~closest_pos_dist, y = ~HangTime,
type = "scatter", mode = "markers", color = I(pt_colors),
marker = list(size = 10, line = list(color = "black", width = 1)),
text = ~paste0("Date: ",Date,"
Batter: ",Batter,"
Pitcher: ",Pitcher,
"
Inning: ",Inning,"
Opportunity Time: ",round(HangTime,2)," sec",
"
Distance Needed: ",round(closest_pos_dist,1)," ft",
"
Catch Probability: ",round(100*catch_prob,1),"%
",star_group),
hoverinfo = "text") %>%
layout(hovermode = "closest",
title = list(text = paste0(player," - ",position,
"
OAA: ",OAA," | Plays: ",n_plays,
" | Expected Catches: ",exp_s," | Actual Catches: ",act_s,""),
font = list(size = 18)), margin = list(t = 80))
})
}
field_graph <- function(player, position, oaa_df) {
if (position %in% c("RF","CF","LF")) {
pd <- oaa_df %>% filter(obs_player == player, hit_location == position)
} else {
pd <- oaa_df %>% filter(obs_player == player) %>% mutate(hit_location = "All")
}
df_f <- pd %>% mutate(
star_group = case_when(catch_prob >= 0.90 ~ "1 Star", catch_prob >= 0.70 ~ "2 Star",
catch_prob >= 0.50 ~ "3 Star", catch_prob >= 0.25 ~ "4 Star",
catch_prob >= 0.00000001 ~ "5 Star"),
avg_y = case_when(position=="CF"~mean(CF_PositionAtReleaseX,na.rm=T),
position=="RF"~mean(RF_PositionAtReleaseX,na.rm=T),
position=="LF"~mean(LF_PositionAtReleaseX,na.rm=T),TRUE~NA_real_),
avg_x = case_when(position=="CF"~mean(CF_PositionAtReleaseZ,na.rm=T),
position=="RF"~mean(RF_PositionAtReleaseZ,na.rm=T),
position=="LF"~mean(LF_PositionAtReleaseZ,na.rm=T),TRUE~NA_real_))
df_table <- df_f %>% group_by(star_group) %>%
summarize(OAA = round(sum(OAA,na.rm=T),1), Plays = n(),
Successes = sum((as.numeric(success_ind)-1),na.rm=T), .groups="drop") %>%
mutate(`Success Rate` = paste0(Successes,"/",Plays," (",round((Successes/Plays)*100,2),"%)")) %>%
dplyr::select(`Star Group` = star_group, `Success Rate`) %>%
t() %>% as.data.frame() %>% `colnames<-`(.[1,]) %>% tibble::as_tibble() %>% dplyr::slice(-1) %>%
mutate(OAA = round(sum(df_f$OAA,na.rm=T),2)) %>% dplyr::select(OAA, everything()) %>%
gt() %>% gt_theme_guardian() %>% tab_header(title = "Play Success by Difficulty") %>%
cols_align(align = "center", columns = everything()) %>%
sub_missing(columns = everything(), missing_text = "-") %>%
tab_options(heading.background.color = "darkcyan", column_labels.background.color = "darkcyan",
table.border.top.color = "peru", table.border.bottom.color = "peru") %>%
tab_style(style = cell_text(color = "white"), locations = cells_title(groups = "title"))
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_segment(aes(x=-1,y=160,xend=1,yend=160),color="black") +
geom_segment(data=curve1,aes(x=x,y=y,xend=xend,yend=yend),size=0.5,color="black",lineend="round") +
geom_segment(data=curve2,aes(x=x,y=y,xend=xend,yend=yend),size=0.5,color="black",lineend="round") +
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_f %>% mutate(is_catch = ifelse(success_ind==1,'Catch',"Hit")),
aes(x=z_pos,y=x_pos,fill=is_catch,
text=paste0("Date: ",Date,
"
Opportunity Time: ",round(HangTime,2)," sec",
"
Pitcher: ",Pitcher,
"
Batter: ",Batter,
"
Distance Needed: ",round(closest_pos_dist,1)," ft",
"
Catch Probability: ",round(100*catch_prob,1),"%
",star_group)),
color="black",shape=21,size=2,alpha=.6) +
labs(title = paste0(player," Possible Catches - ",position)) +
scale_fill_manual(values=c("Hit"="white","Catch"="green4"),name=" ") +
geom_point(data=df_f,aes(x=avg_x,y=avg_y,
text=paste0("Avg Position","
X: ",round(avg_x,1),"
Y: ",round(avg_y,1))),
fill="red",color="black",size=3,shape=21) +
coord_cartesian(xlim=c(-330,330),ylim=c(0,400)) + coord_equal()
p <- ggplotly(p, tooltip = "text") %>% plotly::layout(hovermode = "closest")
list(p, df_table)
}
direction_oaa <- function(player, position, oaa_data) {
dir_levels <- c("Back","Back Left","Left","In Left","In","In Right", "Right", "Back Right")
if (position %in% c("RF","CF","LF")) {
pd <- oaa_data %>% filter(obs_player == player, hit_location == position)
} else {
pd <- oaa_data %>% filter(obs_player == player) %>% mutate(hit_location = "All")
}
pd <- pd %>% mutate(
direction = case_when(
angle_from_home <= -157.5 | angle_from_home >= 157.5 ~ "Back",
angle_from_home <= -112.5 & angle_from_home > -157.5 ~ "Back Right",
angle_from_home <= -67.5 & angle_from_home > -112.5 ~ "Right",
angle_from_home <= -22.5 & angle_from_home > -67.5 ~ "In Right",
angle_from_home > -22.5 & angle_from_home < 22.5 ~ "In",
angle_from_home >= 22.5 & angle_from_home < 67.5 ~ "In Left",
angle_from_home >= 67.5 & angle_from_home < 112.5 ~ "Left",
angle_from_home >= 112.5 & angle_from_home < 157.5 ~ "Back Left"),
direction = factor(direction, levels = dir_levels)) %>%
dplyr::select(Direction = direction, OAA) %>%
group_by(Direction) %>%
summarize(OAA = sum(OAA,na.rm=T), Plays = n(), .groups = "drop") %>%
complete(Direction = dir_levels, fill = list(OAA = 0, Plays = 0)) %>%
arrange(factor(Direction, levels = dir_levels))
tbl <- pd %>% t() %>% as.data.frame() %>% `colnames<-`(.[1,]) %>%
dplyr::slice(-1) %>% tibble::rownames_to_column(var = "Metric") %>%
dplyr::select(Metric, Back, `Back Left`, Left, `In Left`, In, `In Right`, Right, `Back Right`) %>%
mutate(across(Back:`Back Right`, as.numeric)) %>%
gt() %>% gt_theme_guardian() %>% tab_header(title = "Directional OAA") %>%
fmt_number(columns = c(Back,`Back Left`,Left,`In Left`,In,`In Right`,Right,`Back Right`),
rows = Metric == "OAA", decimals = 2) %>%
fmt_number(columns = c(Back,`Back Left`,Left,`In Left`,In,`In Right`,Right,`Back Right`),
rows = Metric != "OAA", decimals = 0) %>%
cols_align(align = "center", columns = everything()) %>%
sub_missing(columns = everything(), missing_text = "-") %>%
tab_options(heading.background.color = "darkcyan", column_labels.background.color = "darkcyan",
table.border.top.color = "peru", table.border.bottom.color = "peru") %>%
tab_style(style = cell_text(color = "white"), locations = cells_title(groups = "title"))
axis_labels <- paste0(pd$Direction, " (", pd$Plays, ")")
radar_data <- pd %>% dplyr::select(Direction, OAA) %>% pivot_wider(names_from = Direction, values_from = OAA)
player_matrix <- rbind(max = rep(5, length(dir_levels)), min = rep(-5, length(dir_levels)),
radar_data[1, dir_levels])
rownames(player_matrix) <- c("max","min",player)
list(player_matrix = player_matrix, axis_labels = axis_labels,
player = player, position = position, table = tbl)
}
infield_star_graph <- function(player, position, IF_OAA) {
if (position %in% c("SS","1B","2B","3B")) {
pd <- IF_OAA %>% filter(obs_player_name == player, obs_player == position)
} else {
pd <- IF_OAA %>% filter(obs_player_name == player) %>% mutate(obs_player = "All")
}
pd <- pd %>% mutate(
star_group = case_when(play_prob>=0.90~"1 Star",play_prob>=0.70~"2 Star",
play_prob>=0.50~"3 Star",play_prob>=0.25~"4 Star",
play_prob>=0.00000001~"5 Star"))
OAA <- round(sum(pd$OAA,na.rm=T),1)
n_plays <- nrow(pd)
exp_s <- round(sum(pd$play_prob,na.rm=T),1)
act_s <- sum(as.numeric(as.character(pd$success_ind)),na.rm=T)
points_data <- pd %>% filter(play_prob > 0) %>%
filter(play_prob <= 0.5 | between(obs_player_bearing_diff, -12.5, 12.5))
p <- ggplot(IF_OAA,
aes(obs_player_bearing_diff, play_prob)) +
stat_summary_2d(aes(z = play_prob), fun = mean, bins = 15) +
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 = "Play Rating", guide = guide_colorbar(barheight = unit(5,"in"))) +
scale_x_continuous("Bearing Difference (degrees)", limits = c(-25,25), breaks = seq(-25,25,12.5)) +
scale_y_continuous("Play Probability", limits = c(0,1), labels = percent) +
theme_minimal() +
theme(legend.position = "right", plot.title = element_text(hjust = 0.5, size = 18, face = "bold"),
panel.grid.minor = element_blank(), panel.grid.major = element_line(color = "gray90"),
axis.title = element_text(size = 12), axis.text = element_text(size = 10))
pt_colors <- ifelse(points_data$success_ind == 1, "green4", "white")
suppressWarnings({
ggplotly(p, tooltip = NULL) %>%
add_trace(data = points_data, x = ~obs_player_bearing_diff, y = ~play_prob,
type = "scatter", mode = "markers", color = I(pt_colors),
marker = list(size = 10, line = list(color = "black", width = 1)),
text = ~paste0("Date: ",Date,"
Batter: ",Batter,"
Pitcher: ",Pitcher,
"
Inning: ",Inning,"
Play Probability: ",round(100*play_prob,1),"%",
"
Angular Distance Away: ",round(obs_player_bearing_diff,1),"\u00ba",
"
Exit Velocity: ",round(ExitSpeed,1)," mph",
"
Distance: ",round(Distance,1)," ft
",star_group),
hoverinfo = "text") %>%
layout(hovermode = "closest",
title = list(text = paste0(player," - ",position,
"
OAA: ",OAA," | Plays: ",n_plays,
" | Expected Plays Made: ",exp_s,
" | Actual Plays Made: ",act_s,""),
font = list(size = 18)), margin = list(t = 80))
})
}
infield_field_graph <- function(player, position, IF_OAA) {
if (position %in% c("SS","1B","2B","3B")) {
pd <- IF_OAA %>% filter(obs_player_name == player, obs_player == position)
} else {
pd <- IF_OAA %>% filter(obs_player_name == player)
}
df_f <- pd %>% mutate(
star_group = case_when(play_prob>=0.90~"1 Star",play_prob>=0.70~"2 Star",
play_prob>=0.50~"3 Star",play_prob>=0.25~"4 Star",
play_prob>=0.00000001~"5 Star"),
rad = Bearing*pi/180, x_pos = Distance*cos(rad), z_pos = Distance*sin(rad)) %>%
group_by(obs_player) %>%
mutate(avg_y = mean(obs_player_x,na.rm=T), avg_x = mean(obs_player_z,na.rm=T)) %>% ungroup()
df_table <- df_f %>% group_by(star_group) %>%
summarize(OAA=round(sum(OAA,na.rm=T),1), Plays=n(),
Successes=sum(as.numeric(as.character(success_ind)),na.rm=T), .groups="drop") %>%
mutate(`Success Rate` = paste0(Successes,"/",Plays," (",round((Successes/Plays)*100,1),"%)")) %>%
dplyr::select(`Star Group` = star_group, `Success Rate`) %>%
t() %>% as.data.frame() %>% `colnames<-`(.[1,]) %>% dplyr::slice(-1) %>%
mutate(OAA = round(sum(df_f$OAA,na.rm=T),1)) %>% dplyr::select(OAA, everything()) %>%
gt() %>% gt_theme_guardian() %>% tab_header(title = "Play Success by Difficulty") %>%
cols_align(align = "center", columns = everything()) %>%
sub_missing(columns = everything(), missing_text = "-") %>%
tab_options(heading.background.color = "darkcyan", column_labels.background.color = "darkcyan",
table.border.top.color = "peru", table.border.bottom.color = "peru") %>%
tab_style(style = cell_text(color = "white"), locations = cells_title(groups = "title"))
p <- ggplot() +
geom_segment(aes(x=0,y=0,xend=100,yend=100),color="black") +
geom_segment(aes(x=0,y=0,xend=-100,yend=100),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_segment(aes(x=-1,y=160,xend=1,yend=160),color="black") +
geom_segment(data=curve1,aes(x=x,y=y,xend=xend,yend=yend),size=0.5,color="black",lineend="round") +
geom_segment(data=curve2,aes(x=x,y=y,xend=xend,yend=yend),size=0.5,color="black",lineend="round") +
theme_void() +
geom_point(data = df_f %>% mutate(is_catch = ifelse(success_ind==1,'Play Was Made',"Play Was Not Made")),
aes(x=z_pos,y=x_pos,fill=is_catch,
text=paste0("Date: ",Date,"
Pitcher: ",Pitcher,"
Batter: ",Batter,
"
Play Probability: ",round(100*play_prob,1),"%",
"
Exit Velocity: ",round(ExitSpeed,1)," mph",
"
Distance: ",round(Distance,1)," ft
",star_group)),
color="black",shape=21,size=2,alpha=.6) +
labs(title = paste0(player," Possible Plays - ",position)) +
scale_fill_manual(values=c("Play Was Not Made"="white","Play Was Made"="green4"),name=" ") +
geom_point(data=df_f,aes(x=avg_x,y=avg_y),fill="red",color="black",size=3,shape=21) +
ylim(0,160) + xlim(-120,120) + coord_equal()
p <- ggplotly(p, tooltip = "text") %>% plotly::layout(hovermode = "closest")
list(p, df_table)
}
infield_positioning_heatmap <- function(team, man_on_first = "No Filter", man_on_second = "No Filter",
man_on_third = "No Filter", BatterHand = "No Filter",
PitcherHand = "No Filter", scorediff = "No Filter",
Date1 = "2025-02-14", Date2 = "2026-06-22",
obs_pitcher = "No Filter", Hitter = "No Filter",
Count = "No Filter", obs_outs = "No Filter",
Opponent = "No Filter") {
td <- def_pos_data %>% filter(PitcherTeam == team) %>%
mutate(scorediff_fieldpov = ifelse(team == away_team,
away_score_before - home_score_before,
home_score_before - away_score_before))
if (man_on_first != "No Filter") td <- td %>% filter(man_on_firstbase == man_on_first)
if (man_on_second != "No Filter") td <- td %>% filter(man_on_secondbase == man_on_second)
if (man_on_third != "No Filter") td <- td %>% filter(man_on_thirdbase == man_on_third)
if (BatterHand != "No Filter") td <- td %>% filter(BatterSide == BatterHand)
if (PitcherHand != "No Filter") td <- td %>% filter(PitcherThrows == PitcherHand)
if (scorediff != "No Filter") td <- td %>% filter(scorediff_fieldpov == as.numeric(scorediff))
td <- td %>% filter(Date >= as.Date(Date1) & Date <= as.Date(Date2))
if (obs_pitcher != "No Filter") td <- td %>% filter(Pitcher == obs_pitcher)
if (Hitter != "No Filter") td <- td %>% filter(Batter == Hitter)
if (Count != "No Filter") td <- td %>% filter(pitch_count == Count)
if (obs_outs != "No Filter") td <- td %>% filter(Outs == as.numeric(obs_outs))
if (Opponent != "No Filter") td <- td %>% filter(BatterTeam == Opponent)
n_obs <- nrow(td)
pos_long <- td %>% pivot_longer(
cols = matches("^(1B|2B|3B|SS|LF|CF|RF)_PositionAtRelease[XZ]$"),
names_to = c("position",".value"),
names_pattern = "^(.+)_PositionAtRelease([XZ])$")
pos_table <- pos_long %>% group_by(position) %>%
summarize(median_x = median(X,na.rm=T), median_z = median(Z,na.rm=T))
p <- ggplot() +
geom_hline(yintercept = seq(0,400,20), linetype = "dotted", color = "gray80", size = 0.3) +
geom_vline(xintercept = seq(-240,240,20), linetype = "dotted", color = "gray80", size = 0.3) +
geom_density_2d_filled(data = pos_long, aes(x = Z, y = X), bins = 35, alpha = 0.5) +
scale_fill_manual(values = colorRampPalette(c("#FFFFFF","#A6CEE3","#1F78B4",
"#FB9A99","#E31A1C","#67000D"))(35)) +
geom_segment(aes(x=0,y=0,xend=233.35,yend=233.35),color="black") +
geom_segment(aes(x=0,y=0,xend=-233.35,yend=233.35),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_segment(aes(x=-1,y=160,xend=1,yend=160),color="black") +
geom_segment(data=curve1,aes(x=x,y=y,xend=xend,yend=yend),size=0.5,color="black",lineend="round") +
geom_segment(data=curve2,aes(x=x,y=y,xend=xend,yend=yend),size=0.5,color="black",lineend="round") +
geom_segment(data=curve3,aes(x=x,y=y,xend=xend,yend=yend),size=0.5,color="black",lineend="round") +
geom_segment(data=curve4,aes(x=x,y=y,xend=xend,yend=yend),size=0.5,color="black",lineend="round") +
geom_point(data=pos_table,aes(median_z,median_x),size=3.5,alpha=1,color="black",fill="black",shape=21,stroke=2.6) +
labs(title=paste0("Starting Fielder Position \u2014 ",team),
subtitle=paste0("Graph created from ",n_obs," available observations of data"),x="",y="") +
ylim(0,411) + xlim(-250,250) + coord_equal() +
theme_void() +
theme(legend.position="none", plot.title=element_text(hjust=.5,size=20),
plot.subtitle=element_text(hjust=0.5), legend.title=element_blank(),
panel.grid.minor=element_blank(), axis.title=element_text(size=12),
axis.text=element_blank(), axis.ticks=element_blank())
p
}
# ============================================================
# PASSWORD
# ============================================================
PASSWORD <- Sys.getenv("password")
# ============================================================
# LOGIN UI
# ============================================================
login_ui <- fluidPage(
tags$style(HTML("
body{background-color:#f0f4f8;font-family:'Segoe UI',Tahoma,Geneva,Verdana,sans-serif;color:#006F71;}
.login-container{max-width:360px;margin:120px auto;background:#A27752;padding:30px 25px;border-radius:8px;
box-shadow:0 4px 15px #A1A1A4;text-align:center;color:white;}
.btn-primary{background-color:#006F71!important;border-color:#006F71!important;color:white!important;
font-weight:bold;width:100%;margin-top:10px;box-shadow:0 2px 5px #006F71;transition:background-color .3s ease;}
.btn-primary:hover{background-color:#006F71!important;border-color:#A27752!important;}
.form-control{border-radius:4px;border:1.5px solid #006F71!important;color:#006F71;font-weight:600;}
")),
div(class = "login-container",
tags$img(src="https://upload.wikimedia.org/wikipedia/en/thumb/e/ef/Coastal_Carolina_Chanticleers_logo.svg/1200px-Coastal_Carolina_Chanticleers_logo.svg.png",height="150px"),
passwordInput("password","Password:"),
actionButton("login","Login"),
textOutput("wrong_pass"))
)
# ============================================================
# MAIN APP UI
# ============================================================
app_ui <- fluidPage(
tags$head(tags$style(HTML("
body,table,.gt_table{font-family:-apple-system,BlinkMacSystemFont,'Segoe UI',Roboto,Helvetica,Arial,sans-serif;}
.app-header{display:flex;justify-content:space-between;align-items:center;padding:20px 40px;background:#fff;border-bottom:3px solid darkcyan;margin-bottom:20px;}
.header-logo-left,.header-logo-right{width:120px;height:auto;}
.header-logo-center{max-width:400px;height:auto;}
@media(max-width:768px){.app-header{flex-direction:column;padding:15px 20px;}.header-logo-left,.header-logo-right{width:80px;}.header-logo-center{max-width:250px;margin:10px 0;}}
.nav-tabs{border:none!important;border-radius:50px;padding:6px 12px;margin:20px auto 0;max-width:100%;
background:linear-gradient(135deg,#d4edeb 0%,#e8ddd0 50%,#d4edeb 100%);box-shadow:0 4px 16px rgba(0,139,139,.12),inset 0 2px 4px rgba(255,255,255,.6);
border:1px solid rgba(0,139,139,.2);position:relative;overflow-x:auto;-webkit-overflow-scrolling:touch;display:flex;justify-content:center;align-items:center;flex-wrap:wrap;gap:6px;}
.nav-tabs::-webkit-scrollbar{height:0;}
.nav-tabs>li>a{color:darkcyan!important;border:none!important;border-radius:50px!important;background:transparent!important;font-weight:700;font-size:14.5px;padding:10px 22px;white-space:nowrap;letter-spacing:.2px;transition:all .2s ease;}
.nav-tabs>li>a:hover{color:#006666!important;background:rgba(255,255,255,.5)!important;transform:translateY(-1px);}
.nav-tabs>li.active>a,.nav-tabs>li.active>a:focus,.nav-tabs>li.active>a:hover{
background:linear-gradient(135deg,#008b8b 0%,#20b2aa 30%,#00ced1 50%,#20b2aa 70%,#008b8b 100%)!important;
color:#fff!important;text-shadow:0 1px 2px rgba(0,0,0,.2);box-shadow:0 4px 16px rgba(0,139,139,.4),inset 0 2px 8px rgba(255,255,255,.4),inset 0 -2px 6px rgba(0,0,0,.2);
border:1px solid rgba(255,255,255,.3)!important;}
.tab-content{background:linear-gradient(135deg,rgba(255,255,255,.95),rgba(248,249,250,.95));border-radius:20px;padding:25px;margin-top:14px;box-shadow:0 15px 40px rgba(0,139,139,.1);backdrop-filter:blur(15px);border:1px solid rgba(0,139,139,.1);position:relative;overflow:hidden;}
.tab-content::before{content:'';position:absolute;left:0;right:0;top:0;height:4px;background:linear-gradient(90deg,darkcyan,peru,darkcyan);background-size:200% 100%;animation:shimmer 3s linear infinite;}
@keyframes shimmer{0%{background-position:-200% 0;}100%{background-position:200% 0;}}
.well{background:#fff;border-radius:12px;border:1px solid rgba(0,139,139,.15);box-shadow:0 6px 18px rgba(0,0,0,.06);}
.control-label{font-weight:700;color:#0a6a6a;}
.selectize-input,.form-control{border-radius:10px;border:1px solid rgba(0,139,139,.35);}
.gt_table{border-radius:12px;overflow:hidden;border:1px solid rgba(0,139,139,.15);}
.section-header{color:darkcyan;border-bottom:2px solid peru;padding-bottom:6px;margin-bottom:16px;}
.stat-box{display:inline-block;background:linear-gradient(135deg,#008b8b,#20b2aa);color:white;border-radius:12px;padding:12px 20px;margin:4px 6px;text-align:center;min-width:120px;box-shadow:0 4px 12px rgba(0,139,139,.25);}
.stat-box .stat-value{font-size:22px;font-weight:800;line-height:1.2;}
.stat-box .stat-label{font-size:11px;font-weight:600;opacity:.85;text-transform:uppercase;letter-spacing:.5px;}
.stat-box-negative{background:linear-gradient(135deg,#c0392b,#e74c3c);}
.stat-box-neutral{background:linear-gradient(135deg,#7f8c8d,#95a5a6);}
"))),
div(class="app-header",
tags$img(src="https://i.imgur.com/7vx5Ci8.png",class="header-logo-left",alt="Logo Left"),
tags$img(src="https://i.imgur.com/Sq0CZ0F.png",class="header-logo-center",alt="Main Logo"),
tags$img(src="https://i.imgur.com/VbrN5WV.png",class="header-logo-right",alt="Logo Right")),
tabsetPanel(id = "tabs",
# =============================================
# TAB 1: Outfield OAA
# =============================================
tabPanel("Outfield OAA",
sidebarLayout(
sidebarPanel(width = 3,
selectInput("of_player","Player:",choices = NULL),
hr(),
checkboxGroupInput("of_year_select","Year:",choices=c("2025","2026"),selected=c("2025","2026")),
hr(),
selectInput("of_position","Position:",choices=c("LF","CF","RF","ALL"),selected="CF")),
mainPanel(width = 9,
h4("Star Graph (Catch Difficulty)", class = "section-header"),
plotlyOutput("of_star_graph", height = "500px"),
hr(),
h4("Field Graph (Catch Locations)", class = "section-header"),
plotlyOutput("of_field_graph_plot", height = "500px"),
gt_output("of_field_graph_table"),
hr(),
h4("Directional OAA", class = "section-header"),
plotOutput("of_direction_radar", height = "400px"),
gt_output("of_direction_oaa_table"))
)
),
# =============================================
# TAB 2: Infield OAA
# =============================================
tabPanel("Infield OAA",
sidebarLayout(
sidebarPanel(width = 3,
selectInput("if_player","Player:",choices = NULL),
hr(),
checkboxGroupInput("if_year_select","Year:",choices=c("2025","2026"),selected=c("2026")),
hr(),
selectInput("if_position","Position:",choices=c("SS","2B","3B","1B","ALL"),selected="SS")),
mainPanel(width = 9,
h4("Star Graph (Play Difficulty)", class = "section-header"),
plotlyOutput("if_star_graph", height = "500px"),
hr(),
h4("Field Graph (Play Locations)", class = "section-header"),
plotlyOutput("if_field_graph_plot", height = "500px"),
gt_output("if_field_graph_table"))
)
),
# =============================================
# TAB 3: Catching (Receiving / Throwing / Blocking)
# =============================================
tabPanel("Catching",
sidebarLayout(
sidebarPanel(width = 3,
selectInput("ct_catcher", "Catcher:", choices = NULL),
hr(),
selectInput("ct_batter_hand", "Batter Hand:",
choices = c("All","Right","Left"), selected = "All"),
selectInput("ct_pitcher_hand", "Pitcher Hand:",
choices = c("All","Right","Left"), selected = "All"),
selectInput("ct_pitch_type", "Pitch Type:",
choices = c("All"), selected = "All"),
selectInput("ct_count", "Count:",
choices = c("All"), selected = "All")
),
mainPanel(width = 9,
tabsetPanel(id = "ct_subtabs",
# ------- RECEIVING SUB-TAB -------
tabPanel("Receiving",
br(),
uiOutput("recv_header_stats"),
hr(),
fluidRow(
column(6,
selectInput("recv_view_mode", "View Mode:",
choices = c("Points","Heatmap","Catch Position (Overhead)","Catch Depth (Side)"),
selected = "Points", width = "100%")),
column(3,
checkboxInput("recv_catchers_view", "Catcher's View", value = FALSE))
),
fluidRow(
column(6,
h4("Strikes Added", class = "section-header"),
plotOutput("recv_strikes_added", height = "480px")),
column(6,
h4("Strikes Lost", class = "section-header"),
plotOutput("recv_strikes_lost", height = "480px"))
),
hr(),
h4("Framing Log", class = "section-header"),
DTOutput("recv_log_table")
),
# ------- THROWING SUB-TAB -------
tabPanel("Throwing",
br(),
uiOutput("throw_header_stats"),
hr(),
fluidRow(
column(4,
selectInput("throw_view_mode", "Base Arrival View:",
choices = c("Points (by Result)","Heatmap","Color by Throw Speed"),
selected = "Points (by Result)", width = "100%")),
column(4,
selectInput("throw_release_color", "Release Point Color By:",
choices = c("Result","Throw Speed"),
selected = "Result", width = "100%"))
),
fluidRow(
column(6,
h4("Outs", class = "section-header"),
plotlyOutput("throw_outs_plot", height = "520px")),
column(6,
h4("Safe", class = "section-header"),
plotlyOutput("throw_safe_plot", height = "520px"))
),
hr(),
fluidRow(
column(6,
h4("Release Point (Front View)", class = "section-header"),
plotlyOutput("throw_release_plot", height = "480px")),
column(6,
h4("Release Point (Side View)", class = "section-header"),
plotlyOutput("throw_release_side_plot", height = "480px"))
),
hr(),
h4("Throwing Log", class = "section-header"),
DTOutput("throw_log_table")
),
# ------- BLOCKING SUB-TAB -------
tabPanel("Blocking",
br(),
uiOutput("block_header_stats"),
hr(),
fluidRow(
column(6,
selectInput("block_view_mode", "View Mode:",
choices = c("Points","Heatmap"),
selected = "Points", width = "100%")),
column(3,
checkboxInput("block_catchers_view", "Catcher's View", value = FALSE))
),
fluidRow(
column(6,
h4("Ground Intersection (Overhead)", class = "section-header"),
plotlyOutput("block_ground_plot", height = "500px")),
column(6,
h4("Blocking (Zone View)", class = "section-header"),
plotOutput("block_zone_plot", height = "500px"))
),
hr(),
h4("Blocking Log", class = "section-header"),
DTOutput("block_log_table")
)
)
)
)
),
# =============================================
# TAB 4: 6th Tool Fielding (placeholder)
# =============================================
tabPanel("6th Tool Fielding", h4("Coming Soon", style="text-align:center;color:darkcyan;padding:60px;")),
# =============================================
# TAB 5: Baserunning
# =============================================
tabPanel("Baserunning",
fluidRow(
column(3,
selectInput("br_player", "Player:", choices = NULL)),
column(3,
selectInput("br_metric", "Rank By:",
choices = c("Hustle %" = "HustlePct",
"Max Sprint Speed" = "MaxSpeed",
"Avg Sprint Speed" = "AvgSpeed",
"No HR/Flyout %" = "NoHR_Flyout"),
selected = "HustlePct"))
),
hr(),
h4("Team Hustle Leaderboard", class = "section-header"),
gt_output("br_leaderboard"),
hr(),
fluidRow(
column(6,
h4("Sprint Speed Comparison", class = "section-header"),
plotlyOutput("br_speed_chart", height = "420px")),
column(6,
h4("Hustle % Rankings", class = "section-header"),
plotlyOutput("br_hustle_chart", height = "420px"))
),
hr(),
fluidRow(
column(6,
h4("Player Speed Profile (Team Percentiles)", class = "section-header"),
plotOutput("br_radar", height = "420px")),
column(6,
h4("Hustle Threshold Breakdown", class = "section-header"),
plotlyOutput("br_threshold_chart", height = "420px"))
)
),
# =============================================
# TAB 6: Team Defensive Positioning
# =============================================
tabPanel("Team Defensive Positioning",
fluidRow(
column(2, selectInput("dp_team","Team:",choices=NULL,selected=NULL)),
column(2, selectInput("dp_man_on_first","Runner on 1st:",choices=c("No Filter","TRUE","FALSE"),selected="No Filter")),
column(2, selectInput("dp_man_on_second","Runner on 2nd:",choices=c("No Filter","TRUE","FALSE"),selected="No Filter")),
column(2, selectInput("dp_man_on_third","Runner on 3rd:",choices=c("No Filter","TRUE","FALSE"),selected="No Filter")),
column(2, selectInput("dp_batter_hand","Bat Hand:",choices=c("No Filter","Right","Left"),selected="No Filter"))),
fluidRow(
column(2, selectInput("dp_pitcher_hand","Pitch Hand:",choices=c("No Filter","Right","Left"),selected="No Filter")),
column(2, selectInput("dp_scorediff","Score Diff:",choices=c("No Filter",-4:4),selected="No Filter")),
column(2, dateInput("dp_date_from","From:",value="2025-02-14")),
column(2, dateInput("dp_date_to","To:",value="2026-06-22")),
column(2, selectInput("dp_pitcher","Pitcher:",choices=c("No Filter"),selected="No Filter"))),
fluidRow(
column(2, selectInput("dp_hitter","Batter:",choices=c("No Filter"),selected="No Filter")),
column(2, selectInput("dp_count","Count:",choices=c("No Filter"),selected="No Filter")),
column(2, selectInput("dp_outs","Outs:",choices=c("No Filter",0,1,2),selected="No Filter")),
column(2, selectInput("dp_opponent","Opponent:",choices=c("No Filter"),selected="No Filter"))),
hr(),
plotOutput("dp_heatmap", height = "700px")
),
# =============================================
# TAB 7: OAA Leaderboard
# =============================================
tabPanel("OAA Leaderboard",
fluidRow(
column(3,
checkboxGroupInput("lb_year_select", "Year:",
choices = c("2025", "2026"), selected = c("2025", "2026"), inline = TRUE)),
column(6,
checkboxGroupInput("lb_position_select", "Position:",
choices = c("LF","CF","RF","SS","2B","3B","1B"),
selected = c("LF","CF","RF","SS","2B","3B","1B"), inline = TRUE))
),
hr(),
gt_output("lb_table")
)
)
)
# ============================================================
# ROOT UI
# ============================================================
ui <- fluidPage(uiOutput("mainUI"))
# ============================================================
# SERVER
# ============================================================
server <- function(input, output, session) {
# ---- Auth ----
authed <- reactiveVal(FALSE)
observeEvent(input$login, {
if (!nzchar(PASSWORD)) { authed(TRUE); output$wrong_pass <- renderText("") }
else if (identical(input$password, PASSWORD)) { authed(TRUE); output$wrong_pass <- renderText("") }
else { authed(FALSE); output$wrong_pass <- renderText("Incorrect password.") }
})
output$mainUI <- renderUI({ if (isTRUE(authed())) app_ui else login_ui })
# ============================================================
# REACTIVE: Active OF data based on year selection
# ============================================================
of_data <- reactive({
req(authed())
req(input$of_year_select)
yrs <- input$of_year_select
if (all(c("2025","2026") %in% yrs)) {
bind_rows(OF_OAA_25, OF_OAA_26)
} else if ("2025" %in% yrs) {
OF_OAA_25
} else {
OF_OAA_26
}
})
# ============================================================
# REACTIVE: Active IF data based on year selection
# ============================================================
if_data <- reactive({
req(authed())
req(input$if_year_select)
yrs <- input$if_year_select
if (all(c("2025","2026") %in% yrs)) {
bind_rows(IF_OAA_25, IF_OAA_26)
} else if ("2025" %in% yrs) {
IF_OAA_25
} else {
IF_OAA_26
}
})
# ============================================================
# REACTIVE: Filtered catcher data
# ============================================================
ct_filtered <- reactive({
req(authed(), input$ct_catcher)
d <- Catcher2026 %>% filter(Catcher == input$ct_catcher)
if (input$ct_batter_hand != "All") d <- d %>% filter(BatterSide == input$ct_batter_hand)
if (input$ct_pitcher_hand != "All") d <- d %>% filter(PitcherThrows == input$ct_pitcher_hand)
if (input$ct_pitch_type != "All") d <- d %>% filter(TaggedPitchType == input$ct_pitch_type)
if (input$ct_count != "All") {
cnt <- input$ct_count
b <- as.numeric(substr(cnt,1,1))
s <- as.numeric(substr(cnt,3,3))
d <- d %>% filter(Balls == b, Strikes == s)
}
d
})
# ============================================================
# POPULATE CATCHER DROPDOWNS
# ============================================================
observeEvent(authed(), {
req(isTRUE(authed()))
catchers <- sort(unique(Catcher2026$Catcher[!is.na(Catcher2026$Catcher) & Catcher2026$Catcher != ""]))
updateSelectInput(session, "ct_catcher", choices = catchers,
selected = if (length(catchers) > 0) catchers[1] else NULL)
ptypes <- sort(unique(Catcher2026$TaggedPitchType[!is.na(Catcher2026$TaggedPitchType)]))
updateSelectInput(session, "ct_pitch_type", choices = c("All", ptypes))
counts <- sort(unique(paste0(Catcher2026$Balls, "-", Catcher2026$Strikes)))
updateSelectInput(session, "ct_count", choices = c("All", counts))
}, ignoreInit = TRUE)
# ============================================================
# POPULATE OF PLAYER DROPDOWN
# ============================================================
observeEvent(list(authed(), input$of_year_select, input$of_position), {
req(isTRUE(authed()), input$of_year_select, input$of_position)
d <- of_data()
pos <- input$of_position
if (pos %in% c("LF","CF","RF")) {
players <- sort(unique(d$obs_player[d$hit_location == pos]))
} else {
players <- sort(unique(d$obs_player))
}
updateSelectInput(session, "of_player", choices = players,
selected = if (length(players) > 0) players[1] else NULL)
}, ignoreInit = TRUE)
# ============================================================
# POPULATE IF PLAYER DROPDOWN
# ============================================================
observeEvent(list(authed(), input$if_year_select, input$if_position), {
req(isTRUE(authed()), input$if_year_select, input$if_position)
d <- if_data()
pos <- input$if_position
if (pos %in% c("SS","2B","3B","1B")) {
players <- sort(unique(d$obs_player_name[d$obs_player == pos]))
} else {
players <- sort(unique(d$obs_player_name))
}
updateSelectInput(session, "if_player", choices = players,
selected = if (length(players) > 0) players[1] else NULL)
}, ignoreInit = TRUE)
# ============================================================
# POPULATE DEFENSIVE POSITIONING DROPDOWNS
# ============================================================
observeEvent(authed(), {
req(isTRUE(authed()))
teams <- sort(unique(def_pos_data$PitcherTeam))
updateSelectInput(session, "dp_team", choices = teams,
selected = if ("CCU_CHN" %in% teams) "CCU_CHN" else teams[1])
}, ignoreInit = TRUE)
observeEvent(list(authed(), input$dp_team), {
req(isTRUE(authed()), input$dp_team)
td <- def_pos_data %>% filter(PitcherTeam == input$dp_team)
pitchers <- sort(unique(td$Pitcher))
batters <- sort(unique(td$Batter))
opponents <- sort(unique(td$BatterTeam))
counts <- sort(unique(td$pitch_count))
updateSelectInput(session, "dp_pitcher", choices = c("No Filter", pitchers))
updateSelectInput(session, "dp_hitter", choices = c("No Filter", batters))
updateSelectInput(session, "dp_opponent", choices = c("No Filter", opponents))
updateSelectInput(session, "dp_count", choices = c("No Filter", counts))
}, ignoreInit = TRUE)
# ============================================================
# OUTFIELD OAA OUTPUTS
# ============================================================
output$of_star_graph <- renderPlotly({
req(input$of_player, input$of_position)
d <- of_data()
pos <- ifelse(input$of_position == "ALL", "ALL", input$of_position)
star_graph(input$of_player, pos, d)
})
of_field_result <- reactive({
req(input$of_player, input$of_position)
d <- of_data()
pos <- ifelse(input$of_position == "ALL", "ALL", input$of_position)
field_graph(input$of_player, pos, d)
})
output$of_field_graph_plot <- renderPlotly({
of_field_result()[[1]]
})
output$of_field_graph_table <- render_gt({
of_field_result()[[2]]
})
of_direction_result <- reactive({
req(input$of_player, input$of_position)
d <- of_data()
pos <- ifelse(input$of_position == "ALL", "ALL", input$of_position)
direction_oaa(input$of_player, pos, d)
})
output$of_direction_radar <- renderPlot({
res <- of_direction_result()
par(mar = c(1, 2, 4, 2))
radarchart(res$player_matrix, axistype = 1, pcol = "#0d56ab", pfcol = "#0d56ab33",
plwd = 3, plty = 1, cglcol = "grey75", cglty = 1, cglwd = 0.8,
caxislabels = c(" "," "," "), calcex = 0.7, vlcex = 0.75, seg = 2,
vlabels = res$axis_labels)
text(-.05, 0.2, "-5 or Worse", cex = 0.7)
text(-.1, 0.55, "0", cex = 0.7)
text(-.2, .95, "+5 or Better", cex = 0.7)
title(paste0(res$player, " - ", res$position, " OAA by Direction"))
})
output$of_direction_oaa_table <- render_gt({
of_direction_result()$table
})
# ============================================================
# INFIELD OAA OUTPUTS
# ============================================================
output$if_star_graph <- renderPlotly({
req(input$if_player, input$if_position)
d <- if_data()
pos <- ifelse(input$if_position == "ALL", "ALL", input$if_position)
infield_star_graph(input$if_player, pos, d)
})
if_field_result <- reactive({
req(input$if_player, input$if_position)
d <- if_data()
pos <- ifelse(input$if_position == "ALL", "ALL", input$if_position)
infield_field_graph(input$if_player, pos, d)
})
output$if_field_graph_plot <- renderPlotly({
if_field_result()[[1]]
})
output$if_field_graph_table <- render_gt({
if_field_result()[[2]]
})
# ============================================================
# DEFENSIVE POSITIONING OUTPUT
# ============================================================
output$dp_heatmap <- renderPlot({
req(input$dp_team)
infield_positioning_heatmap(
team = input$dp_team,
man_on_first = input$dp_man_on_first,
man_on_second = input$dp_man_on_second,
man_on_third = input$dp_man_on_third,
BatterHand = input$dp_batter_hand,
PitcherHand = input$dp_pitcher_hand,
scorediff = input$dp_scorediff,
Date1 = as.character(input$dp_date_from),
Date2 = as.character(input$dp_date_to),
obs_pitcher = input$dp_pitcher,
Hitter = input$dp_hitter,
Count = input$dp_count,
obs_outs = input$dp_outs,
Opponent = input$dp_opponent)
})
# ============================================================
# OAA LEADERBOARD
# ============================================================
lb_data <- reactive({
req(isTRUE(authed()), input$lb_year_select, input$lb_position_select)
yrs <- input$lb_year_select
pos <- input$lb_position_select
of_positions <- intersect(pos, c("LF","CF","RF"))
if_positions <- intersect(pos, c("SS","2B","3B","1B"))
of_combined <- NULL
if (length(of_positions) > 0) {
of_pool <- if (all(c("2025","2026") %in% yrs)) {
bind_rows(OF_OAA_25, OF_OAA_26)
} else if ("2025" %in% yrs) { OF_OAA_25 } else { OF_OAA_26 }
of_combined <- of_pool %>%
filter(hit_location %in% of_positions) %>%
mutate(year = format(as.Date(Date), "%Y")) %>%
filter(year %in% yrs) %>%
group_by(Player = obs_player, Position = hit_location) %>%
summarize(OAA = round(sum(OAA, na.rm = TRUE), 2),
Plays = n(), .groups = "drop")
}
if_combined <- NULL
if (length(if_positions) > 0) {
if_pool <- if (all(c("2025","2026") %in% yrs)) {
bind_rows(IF_OAA_25, IF_OAA_26)
} else if ("2025" %in% yrs) { IF_OAA_25 } else { IF_OAA_26 }
if_combined <- if_pool %>%
filter(obs_player %in% if_positions) %>%
mutate(year = format(as.Date(Date), "%Y")) %>%
filter(year %in% yrs) %>%
group_by(Player = obs_player_name, Position = obs_player) %>%
summarize(OAA = round(sum(OAA, na.rm = TRUE), 2),
Plays = n(), .groups = "drop")
}
bind_rows(of_combined, if_combined) %>%
arrange(desc(OAA))
})
output$lb_table <- render_gt({
req(nrow(lb_data()) > 0)
lb_data() %>%
mutate(Rank = row_number()) %>%
dplyr::select(Rank, Player, Position, OAA, Plays) %>%
gt() %>%
gt_theme_guardian() %>%
tab_header(title = "OAA Leaderboard") %>%
cols_align(align = "center", columns = everything()) %>%
cols_align(align = "left", columns = Player) %>%
fmt_number(columns = OAA, decimals = 2) %>%
tab_options(
heading.background.color = "darkcyan",
column_labels.background.color = "darkcyan",
table.border.top.color = "peru",
table.border.bottom.color = "peru") %>%
tab_style(style = cell_text(color = "white"),
locations = cells_title(groups = "title"))
})
# ============================================================
# BASERUNNING TAB
# ============================================================
observeEvent(authed(), {
req(isTRUE(authed()))
updateSelectInput(session, "br_player",
choices = sort(baserunning$Player),
selected = baserunning$Player[1])
}, ignoreInit = TRUE)
output$br_leaderboard <- render_gt({
req(isTRUE(authed()), input$br_metric)
baserunning %>%
arrange(desc(.data[[input$br_metric]])) %>%
mutate(Rank = row_number()) %>%
dplyr::select(Rank, Player,
`Max Speed (MPH)` = MaxSpeed,
`Avg Speed (MPH)` = AvgSpeed,
`Hustle %` = HustlePct,
`75% Threshold` = Speed75,
`80% Threshold` = Speed80,
`90% Threshold` = Speed90,
`No HR/Flyout %` = NoHR_Flyout) %>%
gt() %>%
gt_theme_guardian() %>%
tab_header(title = "Baserunning Hustle Leaderboard") %>%
fmt_number(columns = c(`Max Speed (MPH)`, `Avg Speed (MPH)`,
`75% Threshold`, `80% Threshold`, `90% Threshold`),
decimals = 2) %>%
fmt_number(columns = c(`Hustle %`, `No HR/Flyout %`), decimals = 2) %>%
cols_align(align = "center", columns = everything()) %>%
cols_align(align = "left", columns = Player) %>%
data_color(columns = `Hustle %`,
palette = c("white", "#008b8b"), domain = c(80, 95)) %>%
data_color(columns = `Max Speed (MPH)`,
palette = c("white", "#cd853f"), domain = c(18, 21)) %>%
data_color(columns = `No HR/Flyout %`,
palette = c("white", "#008b8b"), domain = c(85, 100)) %>%
data_color(columns = `Avg Speed (MPH)`,
palette = c("white", "#20b2aa"), domain = c(15, 19)) %>%
tab_options(
heading.background.color = "darkcyan",
column_labels.background.color = "darkcyan",
table.border.top.color = "peru",
table.border.bottom.color = "peru") %>%
tab_style(style = cell_text(color = "white"),
locations = cells_title(groups = "title"))
})
output$br_speed_chart <- renderPlotly({
req(isTRUE(authed()))
d <- baserunning %>%
arrange(desc(MaxSpeed)) %>%
mutate(Player = factor(Player, levels = rev(Player))) %>%
pivot_longer(cols = c(MaxSpeed, AvgSpeed),
names_to = "Type", values_to = "Speed") %>%
mutate(Type = ifelse(Type == "MaxSpeed",
"Max Sprint Speed", "Avg Sprint Speed"))
p <- ggplot(d, aes(x = Player, y = Speed, fill = Type)) +
geom_col(position = position_dodge(width = 0.7),
width = 0.6, color = "black", size = 0.3) +
scale_fill_manual(values = c("Max Sprint Speed" = "darkcyan",
"Avg Sprint Speed" = "peru")) +
coord_flip() +
labs(x = NULL, y = "Speed (MPH)", fill = NULL) +
theme_minimal() +
theme(legend.position = "top",
panel.grid.major.y = element_blank(),
plot.background = element_rect(fill = "transparent", color = NA))
ggplotly(p, tooltip = c("y", "fill")) %>%
layout(legend = list(orientation = "h", x = 0.15, y = 1.08))
})
output$br_hustle_chart <- renderPlotly({
req(isTRUE(authed()))
d <- baserunning %>%
arrange(HustlePct) %>%
mutate(Player = factor(Player, levels = Player))
p <- ggplot(d, aes(x = Player, y = HustlePct)) +
geom_segment(aes(xend = Player, y = 75, yend = HustlePct),
color = "darkcyan", size = 1.2) +
geom_point(size = 4, color = "peru") +
geom_text(aes(label = paste0(round(HustlePct, 1), "%")),
hjust = -0.3, size = 3, color = "darkcyan", fontface = "bold") +
coord_flip() +
scale_y_continuous(limits = c(75, 100),
labels = function(x) paste0(x, "%")) +
labs(x = NULL, y = "Hustle %") +
theme_minimal() +
theme(panel.grid.major.y = element_blank(),
plot.background = element_rect(fill = "transparent", color = NA))
ggplotly(p, tooltip = c("y")) %>%
layout(showlegend = FALSE)
})
output$br_radar <- renderPlot({
req(isTRUE(authed()), input$br_player)
pct_data <- baserunning %>%
mutate(across(c(MaxSpeed, AvgSpeed, HustlePct, Speed75,
Speed80, Speed90, NoHR_Flyout),
~ percent_rank(.) * 100,
.names = "pct_{.col}"))
player_row <- pct_data %>% filter(Player == input$br_player)
if (nrow(player_row) == 0) return(NULL)
radar_cols <- c("pct_MaxSpeed", "pct_AvgSpeed", "pct_HustlePct",
"pct_Speed75", "pct_Speed80", "pct_Speed90", "pct_NoHR_Flyout")
labels <- c("Max Speed", "Avg Speed", "Hustle %",
"75% Threshold", "80% Threshold", "90% Threshold", "No HR/Flyout %")
radar_matrix <- rbind(
max = rep(100, length(radar_cols)),
min = rep(0, length(radar_cols)),
player_row[, radar_cols]
)
colnames(radar_matrix) <- labels
par(mar = c(1, 2, 3, 2))
radarchart(as.data.frame(radar_matrix),
axistype = 1,
pcol = "darkcyan",
pfcol = scales::alpha("darkcyan", 0.3),
plwd = 3, plty = 1,
cglcol = "grey75", cglty = 1, cglwd = 0.8,
vlcex = 0.85, seg = 4,
caxislabels = c("0th", "25th", "50th", "75th", "100th"))
title(paste0(input$br_player, " \u2014 Speed & Hustle Profile"),
cex.main = 1.3, col.main = "darkcyan")
})
output$br_threshold_chart <- renderPlotly({
req(isTRUE(authed()), input$br_player)
d <- baserunning %>%
filter(Player == input$br_player) %>%
pivot_longer(cols = c(Speed75, Speed80, Speed90),
names_to = "Threshold", values_to = "Speed") %>%
mutate(Threshold = case_when(
Threshold == "Speed75" ~ "75% Hustle",
Threshold == "Speed80" ~ "80% Hustle",
Threshold == "Speed90" ~ "90% Hustle"),
Threshold = factor(Threshold, levels = c("75% Hustle", "80% Hustle", "90% Hustle")))
team_avg <- baserunning %>%
summarize(Speed75 = mean(Speed75, na.rm = TRUE),
Speed80 = mean(Speed80, na.rm = TRUE),
Speed90 = mean(Speed90, na.rm = TRUE)) %>%
pivot_longer(cols = everything(),
names_to = "Threshold", values_to = "TeamAvg") %>%
mutate(Threshold = case_when(
Threshold == "Speed75" ~ "75% Hustle",
Threshold == "Speed80" ~ "80% Hustle",
Threshold == "Speed90" ~ "90% Hustle"),
Threshold = factor(Threshold, levels = c("75% Hustle", "80% Hustle", "90% Hustle")))
d <- left_join(d, team_avg, by = "Threshold")
p <- ggplot(d, aes(x = Threshold)) +
geom_col(aes(y = Speed, fill = "Player"),
width = 0.5, color = "black", size = 0.3) +
geom_point(aes(y = TeamAvg, color = "Team Avg"),
size = 5, shape = 18) +
geom_text(aes(y = Speed, label = paste0(round(Speed, 2), " MPH")),
vjust = -0.5, size = 3.5, fontface = "bold", color = "darkcyan") +
scale_fill_manual(values = c("Player" = "darkcyan"), name = NULL) +
scale_color_manual(values = c("Team Avg" = "peru"), name = NULL) +
scale_y_continuous(limits = c(0, max(baserunning$Speed90, na.rm = TRUE) + 2),
labels = function(x) paste0(x, " MPH")) +
labs(x = NULL, y = "Speed (MPH)",
title = paste0(input$br_player, " vs. Team Average")) +
theme_minimal() +
theme(legend.position = "top",
plot.title = element_text(hjust = 0.5, color = "darkcyan", face = "bold"),
panel.grid.major.x = element_blank(),
plot.background = element_rect(fill = "transparent", color = NA))
ggplotly(p, tooltip = c("y")) %>%
layout(legend = list(orientation = "h", x = 0.25, y = 1.08))
})
# ============================================================
# CATCHING TAB — RECEIVING
# ============================================================
recv_data <- reactive({
d <- ct_filtered()
d <- d %>% mutate(
PlateLocSide = as.numeric(PlateLocSide) / 12,
PlateLocHeight = as.numeric(PlateLocHeight) / 12
)
d
})
output$recv_header_stats <- renderUI({
d <- recv_data()
sa <- d %>% filter(frame == "Strike Added")
sl <- d %>% filter(frame == "Strike Lost")
n_sa <- nrow(sa)
n_sl <- nrow(sl)
net <- n_sa - n_sl
rv_sa <- round(sum(sa$mean_DRE, na.rm = TRUE), 2)
rv_sl <- round(sum(sl$mean_DRE, na.rm = TRUE), 2)
rv_net <- round(rv_sa + rv_sl, 2)
net_class <- if (net > 0) "" else if (net < 0) " stat-box-negative" else " stat-box-neutral"
rv_class <- if (rv_net < 0) "" else if (rv_net > 0) " stat-box-negative" else " stat-box-neutral"
n_pitches <- nrow(d)
rv_per100 <- if (n_pitches > 0) round(rv_net / n_pitches * 100, 2) else 0
div(style = "text-align:center;margin-bottom:10px;",
div(class = "stat-box", div(class = "stat-value", n_sa), div(class = "stat-label", "Strikes Added")),
div(class = "stat-box stat-box-negative", div(class = "stat-value", n_sl), div(class = "stat-label", "Strikes Lost")),
div(class = paste0("stat-box", net_class), div(class = "stat-value", ifelse(net > 0, paste0("+", net), net)), div(class = "stat-label", "Net Strikes")),
div(class = "stat-box", div(class = "stat-value", rv_net), div(class = "stat-label", "Framing RV")),
div(class = "stat-box", div(class = "stat-value", rv_per100), div(class = "stat-label", "RV/100 Pitches"))
)
})
# Zone plot geometry
szr <- data.frame(xmin=-.83083, xmax=.83083, ymin=1.5, ymax=3.3775)
bzr <- data.frame(xmin=-.9975, xmax=.9975, ymin=1.3775, ymax=3.5)
hp_recv <- data.frame(x=c(-.60,.60,.60,0,-.60), y=c(.15,.15,.27,.42,.27))
# Catcher's view: rotate 180 — tip points down, flat edge on top
hp_center_y <- mean(c(.15, .42))
hp_catcher <- data.frame(x=hp_recv$x * -1, y=2*hp_center_y - hp_recv$y)
# Plotly zone shapes for catch position overhead
plotly_zone_shapes <- function() {
list(
list(type="rect", x0=-.83083, x1=.83083, y0=1.5, y1=3.3775,
line=list(color="black", width=2), fillcolor="rgba(0,0,0,0)", layer="above"),
list(type="rect", x0=-.9975, x1=.9975, y0=1.3775, y1=3.5,
line=list(color="gray", width=1, dash="dot"), fillcolor="rgba(0,0,0,0)", layer="above"),
list(type="path",
path="M -0.60 0.15 L 0.60 0.15 L 0.60 0.27 L 0 0.42 L -0.60 0.27 Z",
line=list(color="gray40", width=1.5), fillcolor="rgba(0,0,0,0)", layer="above")
)
}
# Core zone plot function (ggplot, NO plotly)
make_zone_plot <- function(data, title, flip=FALSE) {
if (!nrow(data)) return(
ggplot() + theme_void() + ggtitle(title) +
theme(plot.title = element_text(hjust=.5, size=10, face="bold")))
f <- if (flip) -1 else 1
data <- data %>% mutate(PlateLocSide = PlateLocSide * f)
szr_f <- szr
bzr_f <- bzr
hp_f <- if (flip) hp_catcher else hp_recv
apt <- unique(data$TaggedPitchType[!is.na(data$TaggedPitchType)])
ggplot(data, aes(PlateLocSide, PlateLocHeight)) +
geom_rect(data=bzr_f, aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),
fill=NA, color="gray50", linewidth=.5, linetype="dotted", inherit.aes=FALSE) +
geom_rect(data=szr_f, aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),
fill=NA, color="black", linewidth=.7, inherit.aes=FALSE) +
geom_polygon(data=hp_f, aes(x=x,y=y),
fill=NA, color="gray40", linewidth=.4, inherit.aes=FALSE) +
geom_point(aes(fill=TaggedPitchType), shape=21, size=5,
color="black", stroke=.6, alpha=.95, na.rm=TRUE) +
scale_fill_manual(values=pitch_colors, na.value="grey60",
name="Pitch Type", drop=FALSE, limits=apt) +
coord_equal() +
scale_x_continuous(limits=c(-1.8,1.8)) +
scale_y_continuous(limits=c(0,4.5)) +
labs(title=if(flip) paste(title,"(Catcher's View)") else title) + theme_classic() +
theme(axis.title=element_blank(), axis.text=element_blank(),
axis.ticks=element_blank(), axis.line=element_blank(),
panel.grid=element_blank(),
plot.title=element_text(hjust=.5, size=10, face="bold"),
plot.margin=margin(2,2,2,2), legend.position="none")
}
# Heatmap zone plot function (ggplot, NO plotly)
make_zone_heatmap <- function(data, title, flip=FALSE) {
if (nrow(data) < 3) return(
ggplot() + theme_void() + ggtitle(paste(title, "- Not enough data")) +
theme(plot.title = element_text(hjust=.5, size=10, face="bold")))
f <- if (flip) -1 else 1
data <- data %>% mutate(PlateLocSide = PlateLocSide * f)
hp_f <- if (flip) hp_catcher else hp_recv
ggplot(data, aes(x=PlateLocSide, y=PlateLocHeight)) +
stat_density_2d(aes(fill=after_stat(density)), geom="raster", contour=FALSE) +
scale_fill_gradientn(colours=c("white","#0551bc","#02fbff","#03ff00",
"#fbff00","#ffa503","#ff1f02","#dc1100"),
name="Density") +
geom_rect(data=bzr, aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),
fill=NA, color="gray50", linewidth=.5, linetype="dotted", inherit.aes=FALSE) +
geom_rect(data=szr, aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),
fill=NA, color="black", linewidth=1, inherit.aes=FALSE) +
geom_polygon(data=hp_f, aes(x=x,y=y),
fill=NA, color="black", linewidth=.8, inherit.aes=FALSE) +
coord_fixed(ratio=1) + xlim(-2,2) + ylim(0,4.5) +
ggtitle(if(flip) paste(title,"(Catcher's View)") else title) + theme_void() +
theme(legend.position="right", plot.margin=margin(3,3,3,3),
plot.title=element_text(hjust=0.5, size=12, face="bold"))
}
output$recv_strikes_added <- renderPlot({
d <- recv_data() %>% filter(frame == "Strike Added") %>% mutate(row_num = row_number())
vm <- input$recv_view_mode
flip <- isTRUE(input$recv_catchers_view)
f <- if (flip) -1 else 1
if (vm == "Heatmap") {
make_zone_heatmap(d, "Strikes Added", flip)
} else if (vm == "Catch Position (Overhead)") {
d2 <- d %>% filter(!is.na(CatchPositionX) & !is.na(CatchPositionZ)) %>%
mutate(cpx = as.numeric(CatchPositionX) * f, cpz = as.numeric(CatchPositionZ))
if (nrow(d2) == 0) return(ggplot() + theme_void() + ggtitle("No catch position data"))
plate_oh <- data.frame(x=c(-.708,.708,.708,0,-.708)*f, y=c(.5,.5,0,-.25,0))
bb_left <- data.frame(xmin=-4.208*f, xmax=-0.708*f, ymin=-3, ymax=3)
bb_right <- data.frame(xmin=0.708*f, xmax=4.208*f, ymin=-3, ymax=3)
if (flip) { bb_left <- data.frame(xmin=pmin(bb_left$xmin,bb_left$xmax),xmax=pmax(bb_left$xmin,bb_left$xmax),ymin=-3,ymax=3)
bb_right <- data.frame(xmin=pmin(bb_right$xmin,bb_right$xmax),xmax=pmax(bb_right$xmin,bb_right$xmax),ymin=-3,ymax=3) }
apt <- unique(d2$TaggedPitchType[!is.na(d2$TaggedPitchType)])
ttl <- if(flip) "Strikes Added - Catch Position (Catcher's View)" else "Strikes Added - Catch Position (Overhead)"
ggplot(d2, aes(x=cpx, y=cpz)) +
geom_rect(data=bb_left, aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),
fill=NA, color="gray50", linewidth=.6, inherit.aes=FALSE) +
geom_rect(data=bb_right, aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),
fill=NA, color="gray50", linewidth=.6, inherit.aes=FALSE) +
geom_polygon(data=plate_oh, aes(x=x,y=y), fill="gray95", color="black", linewidth=.8, inherit.aes=FALSE) +
geom_point(aes(fill=TaggedPitchType), shape=21, size=4, color="black", stroke=.6, alpha=.95) +
scale_fill_manual(values=pitch_colors, na.value="grey60", name="Pitch Type", drop=FALSE, limits=apt) +
coord_fixed() + labs(title=ttl, x="Side (ft)", y="Depth (ft)") +
theme_minimal() + theme(plot.title=element_text(hjust=.5, size=10, face="bold"),
legend.position="bottom")
} else if (vm == "Catch Depth (Side)") {
d2 <- d %>% filter(!is.na(CatchPositionZ) & !is.na(CatchPositionY)) %>%
mutate(cpz = as.numeric(CatchPositionZ), cpy = as.numeric(CatchPositionY))
if (nrow(d2) == 0) return(ggplot() + theme_void() + ggtitle("No catch position data"))
apt <- unique(d2$TaggedPitchType[!is.na(d2$TaggedPitchType)])
ggplot(d2, aes(x=cpz, y=cpy)) +
geom_hline(yintercept=c(1.5, 3.3775), color="black", linewidth=.6, linetype="dashed") +
annotate("text", x=min(d2$cpz, na.rm=TRUE)-0.1, y=1.5, label="Zone Bottom", hjust=1, size=2.5, color="gray40") +
annotate("text", x=min(d2$cpz, na.rm=TRUE)-0.1, y=3.3775, label="Zone Top", hjust=1, size=2.5, color="gray40") +
geom_vline(xintercept=0, color="gray50", linewidth=.4, linetype="dotted") +
geom_point(aes(fill=TaggedPitchType), shape=21, size=4, color="black", stroke=.6, alpha=.95) +
scale_fill_manual(values=pitch_colors, na.value="grey60", name="Pitch Type", drop=FALSE, limits=apt) +
labs(title="Strikes Added - Catch Depth (Side)", x="Depth / Z (ft)", y="Height / Y (ft)") +
theme_minimal() + theme(plot.title=element_text(hjust=.5, size=10, face="bold"),
legend.position="bottom")
} else {
make_zone_plot(d, "Strikes Added", flip)
}
})
output$recv_strikes_lost <- renderPlot({
d <- recv_data() %>% filter(frame == "Strike Lost") %>% mutate(row_num = row_number())
vm <- input$recv_view_mode
flip <- isTRUE(input$recv_catchers_view)
f <- if (flip) -1 else 1
if (vm == "Heatmap") {
make_zone_heatmap(d, "Strikes Lost", flip)
} else if (vm == "Catch Position (Overhead)") {
d2 <- d %>% filter(!is.na(CatchPositionX) & !is.na(CatchPositionZ)) %>%
mutate(cpx = as.numeric(CatchPositionX) * f, cpz = as.numeric(CatchPositionZ))
if (nrow(d2) == 0) return(ggplot() + theme_void() + ggtitle("No catch position data"))
plate_oh <- data.frame(x=c(-.708,.708,.708,0,-.708)*f, y=c(.5,.5,0,-.25,0))
bb_left <- data.frame(xmin=-4.208*f, xmax=-0.708*f, ymin=-3, ymax=3)
bb_right <- data.frame(xmin=0.708*f, xmax=4.208*f, ymin=-3, ymax=3)
if (flip) { bb_left <- data.frame(xmin=pmin(bb_left$xmin,bb_left$xmax),xmax=pmax(bb_left$xmin,bb_left$xmax),ymin=-3,ymax=3)
bb_right <- data.frame(xmin=pmin(bb_right$xmin,bb_right$xmax),xmax=pmax(bb_right$xmin,bb_right$xmax),ymin=-3,ymax=3) }
apt <- unique(d2$TaggedPitchType[!is.na(d2$TaggedPitchType)])
ttl <- if(flip) "Strikes Lost - Catch Position (Catcher's View)" else "Strikes Lost - Catch Position (Overhead)"
ggplot(d2, aes(x=cpx, y=cpz)) +
geom_rect(data=bb_left, aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),
fill=NA, color="gray50", linewidth=.6, inherit.aes=FALSE) +
geom_rect(data=bb_right, aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),
fill=NA, color="gray50", linewidth=.6, inherit.aes=FALSE) +
geom_polygon(data=plate_oh, aes(x=x,y=y), fill="gray95", color="black", linewidth=.8, inherit.aes=FALSE) +
geom_point(aes(fill=TaggedPitchType), shape=21, size=4, color="black", stroke=.6, alpha=.95) +
scale_fill_manual(values=pitch_colors, na.value="grey60", name="Pitch Type", drop=FALSE, limits=apt) +
coord_fixed() + labs(title=ttl, x="Side (ft)", y="Depth (ft)") +
theme_minimal() + theme(plot.title=element_text(hjust=.5, size=10, face="bold"),
legend.position="bottom")
} else if (vm == "Catch Depth (Side)") {
d2 <- d %>% filter(!is.na(CatchPositionZ) & !is.na(CatchPositionY)) %>%
mutate(cpz = as.numeric(CatchPositionZ), cpy = as.numeric(CatchPositionY))
if (nrow(d2) == 0) return(ggplot() + theme_void() + ggtitle("No catch position data"))
apt <- unique(d2$TaggedPitchType[!is.na(d2$TaggedPitchType)])
ggplot(d2, aes(x=cpz, y=cpy)) +
geom_hline(yintercept=c(1.5, 3.3775), color="black", linewidth=.6, linetype="dashed") +
annotate("text", x=min(d2$cpz, na.rm=TRUE)-0.1, y=1.5, label="Zone Bottom", hjust=1, size=2.5, color="gray40") +
annotate("text", x=min(d2$cpz, na.rm=TRUE)-0.1, y=3.3775, label="Zone Top", hjust=1, size=2.5, color="gray40") +
geom_vline(xintercept=0, color="gray50", linewidth=.4, linetype="dotted") +
geom_point(aes(fill=TaggedPitchType), shape=21, size=4, color="black", stroke=.6, alpha=.95) +
scale_fill_manual(values=pitch_colors, na.value="grey60", name="Pitch Type", drop=FALSE, limits=apt) +
labs(title="Strikes Lost - Catch Depth (Side)", x="Depth / Z (ft)", y="Height / Y (ft)") +
theme_minimal() + theme(plot.title=element_text(hjust=.5, size=10, face="bold"),
legend.position="bottom")
} else {
make_zone_plot(d, "Strikes Lost", flip)
}
})
output$recv_log_table <- renderDT({
d <- recv_data() %>%
filter(!is.na(frame)) %>%
dplyr::select(Date, Inning, Pitcher, Batter, TaggedPitchType,
PlateLocSide, PlateLocHeight, PitchCall, frame,
RelSpeed, mean_DRE) %>%
mutate(PlateLocSide = round(as.numeric(PlateLocSide), 2),
PlateLocHeight = round(as.numeric(PlateLocHeight), 2),
RelSpeed = round(as.numeric(RelSpeed), 1),
mean_DRE = round(mean_DRE, 3)) %>%
rename(Type = TaggedPitchType, Side = PlateLocSide, Height = PlateLocHeight,
Call = PitchCall, Frame = frame, Velo = RelSpeed, RV = mean_DRE)
datatable(d, options = list(pageLength = 15, scrollX = TRUE), rownames = FALSE)
})
# ============================================================
# CATCHING TAB — THROWING
# ============================================================
throw_data <- reactive({
d <- ct_filtered()
d <- d %>% mutate(
notes_parts = strsplit(as.character(Notes), "\\|"),
has_throw = sapply(notes_parts, function(parts) any(grepl("2b\\s*(out|safe)|3b\\s*(out|safe)", trimws(parts), ignore.case = TRUE))),
throw_label = sapply(notes_parts, function(parts) {
for (p in trimws(parts)) {
lp <- tolower(p)
if (grepl("2b\\s*out", lp)) return("2B Out")
if (grepl("2b\\s*safe", lp)) return("2B Safe")
if (grepl("3b\\s*out", lp)) return("3B Out")
if (grepl("3b\\s*safe", lp)) return("3B Safe")
}
return(NA_character_)
})
) %>%
filter(has_throw == TRUE) %>%
mutate(
throw_result = ifelse(grepl("Out", throw_label), "Out", "Safe"),
throw_base = ifelse(grepl("2B", throw_label), "2B", "3B")
) %>%
dplyr::select(-notes_parts, -has_throw)
d
})
output$throw_header_stats <- renderUI({
td <- throw_data()
if (nrow(td) == 0) return(div(style="text-align:center;color:gray;", "No throwing data available"))
n_total <- nrow(td)
n_out <- sum(td$throw_result == "Out", na.rm = TRUE)
n_safe <- sum(td$throw_result == "Safe", na.rm = TRUE)
cs_pct <- round(100 * n_out / n_total, 1)
avg_ts <- round(mean(td$ThrowSpeed, na.rm = TRUE), 1)
max_ts <- round(max(td$ThrowSpeed, na.rm = TRUE), 1)
avg_pop <- round(mean(td$PopTime, na.rm = TRUE), 3)
avg_exch <- round(mean(td$ExchangeTime, na.rm = TRUE), 3)
avg_ttb <- round(mean(td$TimeToBase, na.rm = TRUE), 3)
rv_total <- round(sum(td$mean_DRE, na.rm = TRUE), 2)
div(style = "text-align:center;margin-bottom:10px;",
div(class = "stat-box", div(class = "stat-value", paste0(cs_pct, "%")), div(class = "stat-label", paste0("CS% (", n_out, "/", n_total, ")"))),
div(class = "stat-box", div(class = "stat-value", avg_ts), div(class = "stat-label", "Avg Throw Velo")),
div(class = "stat-box", div(class = "stat-value", max_ts), div(class = "stat-label", "Max Throw Velo")),
div(class = "stat-box", div(class = "stat-value", avg_pop), div(class = "stat-label", "Avg Pop Time")),
div(class = "stat-box", div(class = "stat-value", avg_exch), div(class = "stat-label", "Avg Exchange")),
div(class = "stat-box", div(class = "stat-value", avg_ttb), div(class = "stat-label", "Avg Time to Base")),
div(class = "stat-box", div(class = "stat-value", rv_total), div(class = "stat-label", "Throwing RV")),
div(class = "stat-box", div(class = "stat-value", if (n_total > 0) round(rv_total / n_total * 100, 2) else 0), div(class = "stat-label", "RV/100")),
div(class = "stat-box", div(class = "stat-value", sum(!is.na(td$ThrowPositionX))), div(class = "stat-label", "Tracked Throws")),
div(class = "stat-box", div(class = "stat-value", round(mean(as.numeric(td$ThrowPositionY), na.rm=TRUE), 2)), div(class = "stat-label", "Avg Release Height")),
div(class = "stat-box", div(class = "stat-value", round(mean(as.numeric(td$ThrowPositionX), na.rm=TRUE), 2)), div(class = "stat-label", "Avg Release Side"))
)
})
make_throw_base_plot <- function(data, title_text, view_mode) {
if (nrow(data) == 0) {
return(ggplotly(ggplot() + theme_void() + ggtitle(title_text) +
theme(plot.title = element_text(hjust=.5, size=11, face="bold"))))
}
xmax_d <- max(abs(data$BasePositionZ), 10, na.rm=TRUE) + 2
ymax_d <- max(data$BasePositionY, 9, na.rm=TRUE) + 1
ymin_d <- min(data$BasePositionY, -5, na.rm=TRUE) - 1
grass <- data.frame(x=c(-xmax_d,xmax_d,xmax_d,-xmax_d), y=c(.25,.25,8,8))
sky <- data.frame(x=c(-xmax_d,xmax_d,xmax_d,-xmax_d), y=c(8,8,ymax_d,ymax_d))
dirt <- data.frame(x=c(-xmax_d,xmax_d,xmax_d,-xmax_d), y=c(-2,-2,.25,.25))
ground <- data.frame(x=c(-xmax_d,xmax_d,xmax_d,-xmax_d), y=c(ymin_d,ymin_d,-2,-2))
base_w <- data.frame(x=c(-1,1,1,-1), y=c(0,0,.45,.45))
base_b <- data.frame(x=c(-1,0,0,-1), y=c(0,0,.45,.45))
if (view_mode == "Heatmap") {
data <- data %>% filter(!is.na(BasePositionZ) & !is.na(BasePositionY))
if (nrow(data) < 3) return(plot_ly() %>% layout(title="Not enough data for heatmap"))
p <- plot_ly(data, x=~BasePositionZ, y=~BasePositionY, type="histogram2dcontour",
colorscale=list(c(0,"rgba(0,0,0,0)"),c(0.25,"#02fbff"),c(0.5,"#03ff00"),c(0.75,"#fbff00"),c(1,"#dc1100")),
showscale=FALSE) %>%
layout(title=list(text=title_text, font=list(size=14)),
xaxis=list(title="", range=c(-xmax_d,xmax_d)),
yaxis=list(title="", range=c(ymin_d,ymax_d), scaleanchor="x"),
shapes=list(
list(type="rect", x0=-xmax_d,x1=xmax_d,y0=0.25,y1=8, fillcolor="rgba(0,139,139,0.15)", line=list(width=0), layer="below"),
list(type="rect", x0=-xmax_d,x1=xmax_d,y0=8,y1=ymax_d, fillcolor="rgba(255,255,0,0.2)", line=list(width=0), layer="below"),
list(type="rect", x0=-xmax_d,x1=xmax_d,y0=-2,y1=0.25, fillcolor="rgba(139,69,19,0.2)", line=list(width=0), layer="below"),
list(type="rect", x0=-1,x1=1,y0=0,y1=0.45, fillcolor="white", line=list(color="black",width=1), layer="above")))
return(p)
}
if (view_mode == "Color by Throw Speed") {
data <- data %>% filter(!is.na(BasePositionZ) & !is.na(BasePositionY) & !is.na(ThrowSpeed))
if (nrow(data) == 0) return(ggplotly(ggplot() + theme_void() + ggtitle("No data")))
p <- ggplot() +
geom_polygon(data=grass, aes(x,y), fill='darkcyan', color='darkcyan') +
geom_polygon(data=sky, aes(x,y), fill='yellow', color='yellow') +
geom_polygon(data=dirt, aes(x,y), fill='brown', color='brown') +
geom_polygon(data=ground, aes(x,y), fill='darkgreen', color='darkgreen') +
geom_polygon(data=base_w, aes(x,y), fill='white', color='black') +
geom_polygon(data=base_b, aes(x,y), fill='lightgrey', color='black') +
geom_point(data=data, aes(x=BasePositionZ, y=BasePositionY, color=ThrowSpeed,
text=paste0("Result: ",throw_label,"
Speed: ",round(ThrowSpeed,1)," mph",
"
Pop Time: ",round(PopTime,3),"s",
"
Exchange: ",round(ExchangeTime,3),"s",
"
Pitcher: ",Pitcher,"
Date: ",Date)),
size=3.5, alpha=.95) +
scale_color_gradientn(colors=c("#0551bc","#02fbff","#03ff00","#fbff00","#ff1f02"),
name="Throw Speed (mph)") +
scale_x_continuous(limits=c(-xmax_d,xmax_d)) + scale_y_continuous(limits=c(ymin_d,ymax_d)) +
theme_bw() + coord_fixed() +
theme(legend.position="bottom", axis.title=element_blank(), axis.text=element_blank(),
axis.ticks=element_blank(), panel.grid=element_blank(),
plot.title=element_text(size=11,face='bold',hjust=.5)) +
ggtitle(title_text)
return(ggplotly(p, tooltip="text"))
}
if (view_mode == "Release Point (Side)") {
data <- data %>% filter(!is.na(ThrowPositionX) & !is.na(ThrowPositionY))
if (nrow(data) == 0) return(ggplotly(ggplot() + theme_void() + ggtitle("No release point data")))
p <- ggplot(data, aes(x=as.numeric(ThrowPositionX), y=as.numeric(ThrowPositionY),
text=paste0("Result: ",throw_label,"
Speed: ",round(ThrowSpeed,1)," mph",
"
Pop: ",round(PopTime,3),"s",
"
Date: ",Date))) +
geom_point(aes(color=throw_label), size=4, alpha=.85) +
scale_color_manual(values=throw_color_map, name="Result") +
labs(title=paste(title_text, "- Release Point (Side)"), x="X (ft)", y="Y (ft)") +
theme_minimal() + coord_equal() +
theme(plot.title=element_text(hjust=.5,size=11,face='bold'), legend.position="bottom")
return(ggplotly(p, tooltip="text"))
}
if (view_mode == "Release Point (Overhead)") {
data <- data %>% filter(!is.na(ThrowPositionX) & !is.na(ThrowPositionZ))
if (nrow(data) == 0) return(ggplotly(ggplot() + theme_void() + ggtitle("No release point data")))
p <- ggplot(data, aes(x=as.numeric(ThrowPositionX), y=as.numeric(ThrowPositionZ),
text=paste0("Result: ",throw_label,"
Speed: ",round(ThrowSpeed,1)," mph",
"
Date: ",Date))) +
geom_point(aes(color=throw_label), size=4, alpha=.85) +
scale_color_manual(values=throw_color_map, name="Result") +
labs(title=paste(title_text, "- Release Point (Overhead)"), x="X (ft)", y="Z (ft)") +
theme_minimal() + coord_equal() +
theme(plot.title=element_text(hjust=.5,size=11,face='bold'), legend.position="bottom")
return(ggplotly(p, tooltip="text"))
}
# Default: Points by Result
p <- ggplot() +
geom_polygon(data=grass, aes(x,y), fill='darkcyan', color='darkcyan') +
geom_polygon(data=sky, aes(x,y), fill='yellow', color='yellow') +
geom_polygon(data=dirt, aes(x,y), fill='brown', color='brown') +
geom_polygon(data=ground, aes(x,y), fill='darkgreen', color='darkgreen') +
geom_polygon(data=base_w, aes(x,y), fill='white', color='black') +
geom_polygon(data=base_b, aes(x,y), fill='lightgrey', color='black') +
geom_point(data=data, aes(x=BasePositionZ, y=BasePositionY, color=throw_label,
text=paste0("Result: ",throw_label,"
Speed: ",round(ThrowSpeed,1)," mph",
"
Pop: ",round(PopTime,3),"s",
"
Exchange: ",round(ExchangeTime,3),"s",
"
TTB: ",round(TimeToBase,3),"s",
"
Pitcher: ",Pitcher,"
Date: ",Date)),
size=4, alpha=.95) +
scale_color_manual(values=throw_color_map) +
scale_x_continuous(limits=c(-xmax_d,xmax_d)) + scale_y_continuous(limits=c(ymin_d,ymax_d)) +
theme_bw() + coord_fixed() +
theme(legend.position="bottom", axis.title=element_blank(), axis.text=element_blank(),
axis.ticks=element_blank(), panel.grid=element_blank(),
plot.title=element_text(size=11,face='bold',hjust=.5)) +
ggtitle(title_text)
ggplotly(p, tooltip="text")
}
output$throw_outs_plot <- renderPlotly({
td <- throw_data() %>% filter(throw_result == "Out")
make_throw_base_plot(td, paste0(input$ct_catcher, " - Outs"), input$throw_view_mode)
})
output$throw_safe_plot <- renderPlotly({
td <- throw_data() %>% filter(throw_result == "Safe")
make_throw_base_plot(td, paste0(input$ct_catcher, " - Safe"), input$throw_view_mode)
})
output$throw_release_plot <- renderPlotly({
td <- throw_data() %>%
filter(!is.na(ThrowPositionX) & !is.na(ThrowPositionY))
if (nrow(td) == 0) {
return(plot_ly() %>% layout(title="No release point data",
xaxis=list(visible=FALSE), yaxis=list(visible=FALSE)))
}
td <- td %>% mutate(tpx = as.numeric(ThrowPositionX), tpy = as.numeric(ThrowPositionY))
color_by <- input$throw_release_color
if (color_by == "Throw Speed") {
p <- plot_ly(td, x=~tpx, y=~tpy, type="scatter", mode="markers",
marker=list(size=12, color=~ThrowSpeed,
colorscale=list(c(0,"#0551bc"),c(0.25,"#02fbff"),c(0.5,"#03ff00"),c(0.75,"#fbff00"),c(1,"#ff1f02")),
colorbar=list(title="Velo (mph)"),
line=list(color="black", width=1)),
text=~paste0("Result: ",throw_label,"
Speed: ",round(ThrowSpeed,1)," mph",
"
Pop: ",round(PopTime,3),"s","
Exchange: ",round(ExchangeTime,3),"s",
"
Date: ",Date),
hoverinfo="text")
} else {
td$pt_color <- sapply(td$throw_label, function(tl) {
if (!is.na(tl) && tl %in% names(throw_color_map)) throw_color_map[tl] else "gray"
})
p <- plot_ly(td, x=~tpx, y=~tpy, type="scatter", mode="markers",
marker=list(size=12, color=~pt_color, line=list(color="black", width=1)),
text=~paste0("Result: ",throw_label,"
Speed: ",round(ThrowSpeed,1)," mph",
"
Pop: ",round(PopTime,3),"s","
Exchange: ",round(ExchangeTime,3),"s",
"
Date: ",Date),
hoverinfo="text", name=~throw_label)
}
p %>% layout(
title=list(text=paste0(input$ct_catcher," - Catcher Release Point"), font=list(size=15)),
xaxis=list(title="Release X (ft)", range=c(-8,8), zeroline=TRUE,
zerolinecolor="gray80", gridcolor="gray90"),
yaxis=list(title="Release Y (ft)", range=c(-8,8), zeroline=TRUE,
zerolinecolor="gray80", gridcolor="gray90", scaleanchor="x"),
showlegend=(color_by == "Result"))
})
output$throw_release_side_plot <- renderPlotly({
td <- throw_data() %>%
filter(!is.na(ThrowPositionY) & !is.na(ThrowPositionZ))
if (nrow(td) == 0) {
return(plot_ly() %>% layout(title="No release point data",
xaxis=list(visible=FALSE), yaxis=list(visible=FALSE)))
}
td <- td %>% mutate(tpy = as.numeric(ThrowPositionY), tpz = as.numeric(ThrowPositionZ))
color_by <- input$throw_release_color
if (color_by == "Throw Speed") {
p <- plot_ly(td, x=~tpz, y=~tpy, type="scatter", mode="markers",
marker=list(size=12, color=~ThrowSpeed,
colorscale=list(c(0,"#0551bc"),c(0.25,"#02fbff"),c(0.5,"#03ff00"),c(0.75,"#fbff00"),c(1,"#ff1f02")),
colorbar=list(title="Velo (mph)"),
line=list(color="black", width=1)),
text=~paste0("Result: ",throw_label,"
Speed: ",round(ThrowSpeed,1)," mph",
"
Pop: ",round(PopTime,3),"s","
Date: ",Date),
hoverinfo="text")
} else {
td$pt_color <- sapply(td$throw_label, function(tl) {
if (!is.na(tl) && tl %in% names(throw_color_map)) throw_color_map[tl] else "gray"
})
p <- plot_ly(td, x=~tpz, y=~tpy, type="scatter", mode="markers",
marker=list(size=12, color=~pt_color, line=list(color="black", width=1)),
text=~paste0("Result: ",throw_label,"
Speed: ",round(ThrowSpeed,1)," mph",
"
Pop: ",round(PopTime,3),"s","
Date: ",Date),
hoverinfo="text", name=~throw_label)
}
p %>% layout(
title=list(text=paste0(input$ct_catcher," - Release Point (Side)"), font=list(size=15)),
xaxis=list(title="Release Z / Side (ft)", range=c(-8,8), zeroline=TRUE,
zerolinecolor="gray80", gridcolor="gray90"),
yaxis=list(title="Release Y / Height (ft)", range=c(-8,8), zeroline=TRUE,
zerolinecolor="gray80", gridcolor="gray90", scaleanchor="x"),
showlegend=(color_by == "Result"))
})
output$throw_log_table <- renderDT({
td <- throw_data() %>%
dplyr::select(Date, Inning, Pitcher, Batter, throw_label, ThrowSpeed, PopTime,
ExchangeTime, TimeToBase, mean_DRE) %>%
mutate(ThrowSpeed = round(ThrowSpeed, 1),
PopTime = round(PopTime, 3),
ExchangeTime = round(ExchangeTime, 3),
TimeToBase = round(TimeToBase, 3),
mean_DRE = round(mean_DRE, 3)) %>%
rename(Result = throw_label, Velo = ThrowSpeed, Pop = PopTime,
Exchange = ExchangeTime, TTB = TimeToBase, RV = mean_DRE)
datatable(td, options = list(pageLength = 15, scrollX = TRUE), rownames = FALSE)
})
# ============================================================
# CATCHING TAB — BLOCKING
# ============================================================
block_data <- reactive({
d <- ct_filtered()
d %>% filter(sapply(strsplit(as.character(Notes), "\\|"), function(parts) {
any(.is_block_event(trimws(parts)))
})) %>% mutate(
block_type = .classify_block_type(Notes),
PlateLocSide = as.numeric(PlateLocSide) / 12,
PlateLocHeight = as.numeric(PlateLocHeight) / 12
)
})
output$block_header_stats <- renderUI({
bd <- block_data()
if (nrow(bd) == 0) return(div(style="text-align:center;color:gray;", "No blocking data available"))
n_total <- nrow(bd)
n_block <- sum(bd$block_type == "Block", na.rm = TRUE)
n_pbwp <- sum(bd$block_type == "PB/WP", na.rm = TRUE)
block_pct <- round(100 * n_block / n_total, 1)
rv_total <- round(sum(bd$mean_DRE, na.rm = TRUE), 2)
rv_block <- round(sum(bd$mean_DRE[bd$block_type == "Block"], na.rm = TRUE), 2)
rv_pbwp <- round(sum(bd$mean_DRE[bd$block_type == "PB/WP"], na.rm = TRUE), 2)
div(style = "text-align:center;margin-bottom:10px;",
div(class = "stat-box", div(class = "stat-value", n_total), div(class = "stat-label", "Opportunities")),
div(class = "stat-box", div(class = "stat-value", n_block), div(class = "stat-label", "Blocks")),
div(class = "stat-box stat-box-negative", div(class = "stat-value", n_pbwp), div(class = "stat-label", "PB/WP")),
div(class = "stat-box", div(class = "stat-value", paste0(block_pct, "%")), div(class = "stat-label", "Block %")),
div(class = "stat-box", div(class = "stat-value", rv_total), div(class = "stat-label", "Blocking RV")),
div(class = "stat-box", div(class = "stat-value", if (n_total > 0) round(rv_total / n_total * 100, 2) else 0), div(class = "stat-label", "RV/100"))
)
})
output$block_ground_plot <- renderPlotly({
bd <- block_data()
view_mode <- input$block_view_mode
req_cols <- c("x0","vx0","ax0","y0","vy0","ay0","z0","vz0","az0")
bd <- bd %>% filter(!is.na(x0) & !is.na(z0) & !is.na(az0))
if (!all(req_cols %in% names(bd)) || nrow(bd) == 0) {
return(ggplotly(ggplot() + theme_void() + ggtitle("Ground Intersection") +
theme(plot.title=element_text(hjust=.5,size=11,face="bold"))))
}
bd <- catcher_compute_ground_intersection(bd)
bd <- bd %>% filter(!is.na(x_ground) & !is.na(y_ground)) %>%
mutate(plot_x = x_ground, plot_y = y_ground, row_num = row_number())
if (nrow(bd) == 0) {
return(ggplotly(ggplot() + theme_void() + ggtitle("No ground intersection data")))
}
plate <- data.frame(x=c(-.708,.708,.708,0,-.708), y=c(1.417,1.417,.708,0,.708))
bi <- 1; bo <- 4; bymin <- -2.5; bymax <- 3.7
if (view_mode == "Heatmap" && nrow(bd) >= 3) {
p <- plot_ly(bd, x=~plot_x, y=~plot_y, type="histogram2dcontour",
colorscale=list(c(0,"white"),c(0.25,"#0551bc"),c(0.5,"#03ff00"),c(0.75,"#fbff00"),c(1,"#dc1100")),
showscale=FALSE) %>%
layout(title=list(text="Blocking (Overhead) - Heatmap", font=list(size=14)),
xaxis=list(title=""), yaxis=list(title="", scaleanchor="x"),
shapes=list(
list(type="rect", x0=bi,x1=bo,y0=bymin,y1=bymax, line=list(color="black",width=2), fillcolor="rgba(0,0,0,0)"),
list(type="rect", x0=-bo,x1=-bi,y0=bymin,y1=bymax, line=list(color="black",width=2), fillcolor="rgba(0,0,0,0)"),
list(type="path",
path="M -0.708 1.417 L 0.708 1.417 L 0.708 0.708 L 0 0 L -0.708 0.708 Z",
line=list(color="black",width=2), fillcolor="rgba(0,0,0,0)")))
return(p)
}
# Points mode
sl <- unique(bd$block_type)
sv <- c("Block"=21,"PB/WP"=24)[sl]
p <- ggplot(bd, aes(plot_x, plot_y,
text=paste0("#",row_num,"
Pitch: ",TaggedPitchType,
"
Type: ",block_type,
"
Pitcher: ",Pitcher,"
Batter: ",Batter,
"
Velo: ",round(RelSpeed,1)," mph",
"
RV: ",round(mean_DRE,3),
"
Date: ",Date))) +
geom_segment(aes(x=bi,xend=bo,y=bymin,yend=bymin), color="black", linewidth=.8, inherit.aes=FALSE) +
geom_segment(aes(x=bi,xend=bo,y=bymax,yend=bymax), color="black", linewidth=.8, inherit.aes=FALSE) +
geom_segment(aes(x=bi,xend=bi,y=bymin,yend=bymax), color="black", linewidth=.8, inherit.aes=FALSE) +
geom_segment(aes(x=bo,xend=bo,y=bymin,yend=bymax), color="black", linewidth=.8, inherit.aes=FALSE) +
geom_segment(aes(x=-bi,xend=-bo,y=bymin,yend=bymin), color="black", linewidth=.8, inherit.aes=FALSE) +
geom_segment(aes(x=-bi,xend=-bo,y=bymax,yend=bymax), color="black", linewidth=.8, inherit.aes=FALSE) +
geom_segment(aes(x=-bi,xend=-bi,y=bymin,yend=bymax), color="black", linewidth=.8, inherit.aes=FALSE) +
geom_segment(aes(x=-bo,xend=-bo,y=bymin,yend=bymax), color="black", linewidth=.8, inherit.aes=FALSE) +
geom_polygon(data=plate, aes(x,y), fill=NA, color="black", linewidth=.8, inherit.aes=FALSE) +
geom_point(aes(fill=TaggedPitchType, shape=block_type), size=4, color="black", stroke=.6) +
scale_fill_manual(values=pitch_colors, na.value="grey60", name="Pitch Type") +
scale_shape_manual(values=sv, name=NULL) +
coord_fixed() + labs(title="Blocking (Overhead View)", x=NULL, y=NULL) +
theme_void(base_size=9) +
theme(plot.title=element_text(size=11,face="bold",hjust=.5),
legend.position="bottom", legend.box="vertical")
ggplotly(p, tooltip="text")
})
output$block_zone_plot <- renderPlot({
bd <- block_data() %>%
filter(!is.na(PlateLocSide) & !is.na(PlateLocHeight)) %>%
mutate(row_num = row_number())
view_mode <- input$block_view_mode
flip <- isTRUE(input$block_catchers_view)
f <- if (flip) -1 else 1
if (nrow(bd) == 0) return(
ggplot() + theme_void() + ggtitle("Blocking (Zone)") +
theme(plot.title = element_text(hjust=.5, size=10, face="bold")))
if (view_mode == "Heatmap" && nrow(bd) >= 3) {
return(make_zone_heatmap(bd, "Blocking (Zone) - Heatmap", flip))
}
bd <- bd %>% mutate(PlateLocSide = PlateLocSide * f)
hp_f <- if (flip) hp_catcher else hp_recv
sl <- unique(bd$block_type)
sv <- c("Block"=21, "PB/WP"=24)[sl]
slb <- c("Block"="Block", "PB/WP"="PB/WP")[sl]
tc <- bd %>% count(TaggedPitchType) %>% mutate(label=paste0(TaggedPitchType,": ",n))
cl <- setNames(tc$label, tc$TaggedPitchType)
ttl <- if(flip) "Blocking (Zone) - Catcher's View" else "Blocking (Zone)"
ggplot(bd, aes(PlateLocSide, PlateLocHeight)) +
geom_rect(data=bzr, aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),
fill=NA, color="gray50", linewidth=.6, linetype="dotted", inherit.aes=FALSE) +
geom_rect(data=szr, aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),
fill=NA, color="black", linewidth=.8, inherit.aes=FALSE) +
geom_polygon(data=hp_f, aes(x=x,y=y),
fill=NA, color="gray40", linewidth=.5, inherit.aes=FALSE) +
geom_point(aes(fill=TaggedPitchType, shape=block_type), size=4, color="black", stroke=.6, na.rm=TRUE) +
scale_fill_manual(values=pitch_colors, na.value="grey60", name="Pitch Type", labels=cl) +
scale_shape_manual(values=sv, name=NULL, labels=slb) +
coord_equal(xlim=c(-2.5,2.5), ylim=c(-1,4.5)) +
labs(title=ttl) + theme_void() +
theme(plot.title=element_text(hjust=.5, size=10, face="bold"),
legend.position="bottom", legend.box="vertical",
legend.spacing.y=unit(2,"pt"),
legend.title=element_text(size=7, face="bold"),
legend.text=element_text(size=6),
legend.key.size=unit(.5,"lines")) +
guides(fill=guide_legend(order=1, nrow=2, override.aes=list(size=3, shape=21)),
shape=guide_legend(order=2, nrow=1, override.aes=list(size=3, fill="#4472C4")))
})
output$block_log_table <- renderDT({
bd <- block_data() %>%
dplyr::select(Date, Inning, Pitcher, Batter, TaggedPitchType,
PlateLocSide, PlateLocHeight, block_type, RelSpeed, mean_DRE) %>%
mutate(PlateLocSide = round(as.numeric(PlateLocSide), 2),
PlateLocHeight = round(as.numeric(PlateLocHeight), 2),
RelSpeed = round(as.numeric(RelSpeed), 1),
mean_DRE = round(mean_DRE, 3)) %>%
rename(Type = TaggedPitchType, Side = PlateLocSide, Height = PlateLocHeight,
Result = block_type, Velo = RelSpeed, RV = mean_DRE)
datatable(bd, options = list(pageLength = 15, scrollX = TRUE), rownames = FALSE)
})
}
shinyApp(ui, server)