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