Spaces:
Sleeping
Sleeping
| 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,"<br>Batter: ",Batter,"<br>Pitcher: ",Pitcher, | |
| "<br>Inning: ",Inning,"<br>Opportunity Time: ",round(HangTime,2)," sec", | |
| "<br>Distance Needed: ",round(closest_pos_dist,1)," ft", | |
| "<br>Catch Probability: ",round(100*catch_prob,1),"%<br>",star_group), | |
| hoverinfo = "text") %>% | |
| layout(hovermode = "closest", | |
| title = list(text = paste0(player," - ",position, | |
| "<br><sup>OAA: ",OAA," | Plays: ",n_plays, | |
| " | Expected Catches: ",exp_s," | Actual Catches: ",act_s,"</sup>"), | |
| 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, | |
| "<br>Opportunity Time: ",round(HangTime,2)," sec", | |
| "<br>Pitcher: ",Pitcher, | |
| "<br>Batter: ",Batter, | |
| "<br>Distance Needed: ",round(closest_pos_dist,1)," ft", | |
| "<br>Catch Probability: ",round(100*catch_prob,1),"%<br>",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","<br>X: ",round(avg_x,1),"<br>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,"<br>Batter: ",Batter,"<br>Pitcher: ",Pitcher, | |
| "<br>Inning: ",Inning,"<br>Play Probability: ",round(100*play_prob,1),"%", | |
| "<br>Angular Distance Away: ",round(obs_player_bearing_diff,1),"\u00ba", | |
| "<br>Exit Velocity: ",round(ExitSpeed,1)," mph", | |
| "<br>Distance: ",round(Distance,1)," ft<br>",star_group), | |
| hoverinfo = "text") %>% | |
| layout(hovermode = "closest", | |
| title = list(text = paste0(player," - ",position, | |
| "<br><sup>OAA: ",OAA," | Plays: ",n_plays, | |
| " | Expected Plays Made: ",exp_s, | |
| " | Actual Plays Made: ",act_s,"</sup>"), | |
| 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,"<br>Pitcher: ",Pitcher,"<br>Batter: ",Batter, | |
| "<br>Play Probability: ",round(100*play_prob,1),"%", | |
| "<br>Exit Velocity: ",round(ExitSpeed,1)," mph", | |
| "<br>Distance: ",round(Distance,1)," ft<br>",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,"<br>Speed: ",round(ThrowSpeed,1)," mph", | |
| "<br>Pop Time: ",round(PopTime,3),"s", | |
| "<br>Exchange: ",round(ExchangeTime,3),"s", | |
| "<br>Pitcher: ",Pitcher,"<br>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,"<br>Speed: ",round(ThrowSpeed,1)," mph", | |
| "<br>Pop: ",round(PopTime,3),"s", | |
| "<br>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,"<br>Speed: ",round(ThrowSpeed,1)," mph", | |
| "<br>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,"<br>Speed: ",round(ThrowSpeed,1)," mph", | |
| "<br>Pop: ",round(PopTime,3),"s", | |
| "<br>Exchange: ",round(ExchangeTime,3),"s", | |
| "<br>TTB: ",round(TimeToBase,3),"s", | |
| "<br>Pitcher: ",Pitcher,"<br>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,"<br>Speed: ",round(ThrowSpeed,1)," mph", | |
| "<br>Pop: ",round(PopTime,3),"s","<br>Exchange: ",round(ExchangeTime,3),"s", | |
| "<br>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,"<br>Speed: ",round(ThrowSpeed,1)," mph", | |
| "<br>Pop: ",round(PopTime,3),"s","<br>Exchange: ",round(ExchangeTime,3),"s", | |
| "<br>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,"<br>Speed: ",round(ThrowSpeed,1)," mph", | |
| "<br>Pop: ",round(PopTime,3),"s","<br>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,"<br>Speed: ",round(ThrowSpeed,1)," mph", | |
| "<br>Pop: ",round(PopTime,3),"s","<br>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,"<br>Pitch: ",TaggedPitchType, | |
| "<br>Type: ",block_type, | |
| "<br>Pitcher: ",Pitcher,"<br>Batter: ",Batter, | |
| "<br>Velo: ",round(RelSpeed,1)," mph", | |
| "<br>RV: ",round(mean_DRE,3), | |
| "<br>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) |