The purpose of this program is to flag players who are struggling and help determine why they are struggling. Using this tool, player development staff can work with struggling players to get them back on track.

In reality, this program would flag players from across all of the Reds’ full-season affiliates. However, for demonstration purposes, I will use the the Reds’ 2023 MLB data.

#library(baseballr)
#library(tidyverse)
#library(lubridate)


# Load 2023 Statcast data
load("G:/My Drive/Baseball/R Projects/Data/Statcast2023.RData")

# filter to Reds hitters
reds_data <- Statcast2023 %>%
  filter((inning_topbot == 'Top' & away_team == 'CIN') | (inning_topbot == 'Bot' & home_team == 'CIN'))

Identifying slumps

The get_slump_dates() function flags dates in which a player can be considered to be in a slump. The specifications for a slump can be changed, but the default specifications are as follows.

get_slump_dates <- function(player, length = 20) {

# Create player-specific data frame
player_data <- reds_data %>%
  filter(player_name == player)

# Calculate statistics to date for each date in the player data
# Then, calculate the last length days data at each date

over_time <- data.frame()
dates <- unique(player_data$game_date) # list of dates

for (d in dates) { # loop through all dates
  
  # data to date
  data_to_date <- filter(player_data, game_type == 'R' & game_date <= d)
  
  
  
  ############# Set up stat calculations ###############
  
  
  
  # Define count labels
  walk_count <- sum(data_to_date$events == "walk")
  strikeout_count <- sum(data_to_date$events == "strikeout")
  hit_by_pitch_count <- sum(data_to_date$events == "hit_by_pitch")
  bip_count <- (sum(data_to_date$bb_type == "line_drive"))+
    (sum(data_to_date$bb_type == "ground_ball"))+
    (sum(data_to_date$bb_type == "fly_ball"))+
    (sum(data_to_date$bb_type == "popup"))
  home_run_count <- sum(data_to_date$events == 'home_run')
  
  # Define vectors for events
  hits_vector <- c('single', 'double', 'triple', 'home_run')
  at_bats_vector <- c('field_out', 'strikeout', 'grounded_into_double_play', 'fielders_choice', 'fielders_choice_out', 'triple_play', 'strikeout_double_play', 'double_play', 'field_error', 'force_out', hits_vector)
  plate_appearances_vector <- c(at_bats_vector, 'sac_fly', 'walk', 'hit_by_pitch', 'sac_bunt', 'sac_bunt_double_play', 'sac_fly_double_play', 'catcher_interf')
  swings_vector <- c('hit_into_play', 'swinging_strike_blocked', 'swinging_strike', 'foul_tip', 'foul')
  
  
  
  ################# Calculate stats to date #################
  
  
  
  # Calculate plate appearances (PA)
  PA <- sum(data_to_date$events %in% plate_appearances_vector)
  
  # Calculate BABIP
  babip <- (sum(data_to_date$events %in% hits_vector) -
              home_run_count) / bip_count
  
  # Calculate wOBA
  woba_sum <- sum(data_to_date$woba_value, na.rm = TRUE)
  woba_denominator <- sum(data_to_date$events %in% at_bats_vector) +
    walk_count +
    hit_by_pitch_count +
    sum(data_to_date$events == 'sac_fly')
  woba <- woba_sum / woba_denominator
  
  
  
  ################ Calculate the same stats for ##################
  ################ each date over specified period of time #######
  ################ e.g. last 20 days #############################
  
  
  # Create a vector of dates to use for the length day window
  last_length_data <- player_data %>%
        filter(game_type == 'R' & game_date <= d & game_date >= (d - length))
  
  # Define count labels
  walk_count <- sum(last_length_data$events == "walk")
  strikeout_count  <- sum(last_length_data$events == "strikeout")
  hit_by_pitch_count <- sum(last_length_data$events == "hit_by_pitch")
  bip_count <- (sum(last_length_data$bb_type == "line_drive"))+
    (sum(last_length_data$bb_type == "ground_ball"))+
    (sum(last_length_data$bb_type == "fly_ball"))+
    (sum(last_length_data$bb_type == "popup"))
  home_run_count <- sum(last_length_data$events == 'home_run')
  
  
  
  
  # Calculate plate appearances (PA)
  PA_length <- sum(last_length_data$events %in% plate_appearances_vector)
  
  # Calculate BABIP
  babip_length <- (sum(last_length_data$events %in% hits_vector) -
              home_run_count) / bip_count
  
  # Calculate wOBA
  woba_sum <- sum(last_length_data$woba_value, na.rm = TRUE)
  woba_denominator <- sum(last_length_data$events %in% at_bats_vector) +
    walk_count +
    hit_by_pitch_count +
    sum(last_length_data$events == 'sac_fly')
  woba_length <- woba_sum / woba_denominator
  
  
  
  # Create a row for the current player in over_time
  new_row <- data.frame(Date = as.Date(d, origin = "1970-01-01"), 
                        Name = player, 
                        PA = PA, 
                        wOBA = woba,
                        BABIP = babip,
                        PA_length = PA_length,
                        wOBA_length = woba_length,
                        BABIP_length = babip_length)
  
  
  over_time <- rbind(over_time, new_row)
}

# add a column to identify slumps
# Define a slump as a row where the wOBA_length is less than 80% of total wOBA
# and the BABIP_length is NOT less than 80% of BABIP (i.e. not bad luck)

over_time <- over_time %>%
  mutate(slump = ifelse(wOBA_length < wOBA * 0.8 & BABIP_length > BABIP * 0.8, 1, 0))


slump_dates <- filter(over_time, slump == 1)$Date

return(slump_dates)

}

The resulting list shows the dates when Ian Happ would be considered to be in a slump.

happ_dates <- get_slump_dates('Steer, Spencer', length = 20)

happ_dates
## [1] "2023-05-05" "2023-07-21" "2023-07-23" "2023-07-24" "2023-07-25"
## [6] "2023-07-28" "2023-07-29" "2023-07-30" "2023-07-31"

Look for explanations for the slump

The next step is to explore the data for Happ’s June slump and look for possible explanations. Compare his tendencies over the slump period with his tendencies over the entire season.

This analysis is meant to describe approach, rather than production. This creates coachable insights. Many metrics can be used, but for demonstration purposes, I have selected the following:

In further development, the analysis of slumping players can be vastly expanded. It can include anything from plate coverage visualizations to spray charts to pitch type heat maps. Also,a similar analysis can be run on players performing better than usual.

# Create function

slump_comps <- function(player, date) { 

slump_date <- as.Date(date)
player_data <- filter(reds_data, player_name == player)

# slump_data is the slump date and up to 20 days prior

slump_data <- filter(player_data, game_type == 'R' & game_date <= slump_date & game_date >= (slump_date - 20))

# Define vectors for events
  hits_vector <- c('single', 'double', 'triple', 'home_run')
  at_bats_vector <- c('field_out', 'strikeout', 'grounded_into_double_play', 'fielders_choice', 'fielders_choice_out', 'triple_play', 'strikeout_double_play', 'double_play', 'field_error', 'force_out', hits_vector)
  plate_appearances_vector <- c(at_bats_vector, 'sac_fly', 'walk', 'hit_by_pitch', 'sac_bunt', 'sac_bunt_double_play', 'sac_fly_double_play', 'catcher_interf')
  swings_vector <- c('hit_into_play', 'swinging_strike_blocked', 'swinging_strike', 'foul_tip', 'foul')


##################### Calculate metrics for slump to #######################
##################### identify potential explanations. #####################


# Calculate pitches per PA 

pitches_per_pa_slump <- nrow(slump_data) / sum(slump_data$events %in% plate_appearances_vector)

# Calculate chase rate on breaking balls

balls <- filter(slump_data, true_zone == 'ball')

chase_rate_slump <- sum(balls$description %in% swings_vector) / nrow(balls)

# Calculate pull percentage

   bip_count <- (sum(slump_data$bb_type == "line_drive"))+
    (sum(slump_data$bb_type == "ground_ball"))+
    (sum(slump_data$bb_type == "fly_ball"))+
    (sum(slump_data$bb_type == "popup"))
   
  pull_percentage_slump <- sum((slump_data$stand == 'R' & 
                          slump_data$hc_x < 125.42) |
                          (slump_data$stand == 'L' &
                           slump_data$hc_x > 125.42), na.rm = TRUE) /
                    bip_count
  
  # Calculate oppo percentage
  
  oppo_percentage_slump <- sum((slump_data$stand == 'R' & 
                          slump_data$hc_x > 125.42) |
                          (slump_data$stand == 'L' &
                          slump_data$hc_x < 125.42), na.rm = TRUE) /
                    bip_count
  
  # Calculate first pitch swing rate
  
  first_pitch <- filter(slump_data, balls == 0 & strikes == 0)
  
  fp_swing_rate_slump <- sum(first_pitch$description %in% swings_vector) / nrow(first_pitch)



################### Calculate same metrics for season data to compare #############


# Pitches per PA

pitches_per_pa_season <- nrow(player_data) / sum(player_data$events %in% plate_appearances_vector)


# Chase rate BB

balls <- filter(player_data, true_zone == 'ball')
chase_rate_season <- sum(balls$description %in% swings_vector) / nrow(balls)

# Pull percentage

   bip_count <- (sum(player_data$bb_type == "line_drive"))+
    (sum(player_data$bb_type == "ground_ball"))+
    (sum(player_data$bb_type == "fly_ball"))+
    (sum(player_data$bb_type == "popup"))
   
  pull_percentage_season <- sum((player_data$stand == 'R' & 
                          player_data$hc_x < 125.42) |
                          (player_data$stand == 'L' &
                           player_data$hc_x > 125.42), na.rm = TRUE) /
                    bip_count
  
  # Oppo Percentage
  
  oppo_percentage_season <- sum((player_data$stand == 'R' & 
                          player_data$hc_x > 125.42) |
                          (player_data$stand == 'L' &
                          player_data$hc_x < 125.42), na.rm = TRUE) /
                    bip_count
  
  # First pitch swing rate
  
  first_pitch <- filter(player_data, balls == 0 & strikes == 0)
  
  fp_swing_rate_season <- sum(first_pitch$description %in% swings_vector) / nrow(first_pitch)


################  Create data frame to compare ############################


comparison <- data.frame(Metric = c('Pitches per PA', 'Chase Rate BB', 'Pull Percentage',
                                    'Oppo Percentage', 'First Pitch Swing Rate'),
                         Slump = c(round(pitches_per_pa_slump,2), round(chase_rate_slump,2), 
                                   round(pull_percentage_slump,2),round(oppo_percentage_slump,2), 
                                   round(fp_swing_rate_slump,2)),
                         Season = c(round(pitches_per_pa_season,2), round(chase_rate_season,2), 
                                  round(pull_percentage_season,2),round(oppo_percentage_season,2), 
                                  round(fp_swing_rate_season,2)))

  
return(comparison)

}

Application:

slump_comps('Benson, Will', '2023-09-06')
##                   Metric Slump Season
## 1         Pitches per PA  4.03   4.16
## 2          Chase Rate BB  0.28   0.21
## 3        Pull Percentage  0.56   0.63
## 4        Oppo Percentage  0.44   0.37
## 5 First Pitch Swing Rate  0.32   0.29

This data offers a few possible explanations for Benson’s slump. He seems to be much less patient in the box lately compared to his normal approach. He is seeing significantly fewer pitches per PA (4.16 -> 4.03), and he has been slightly more inclined to swing at the first pitch (29% -> 32%). He has also been chasing breaking balls at a significantly higher rate (21% -> 28%). From a player development perspective, the most likely recommendation would be to encourage Benson to be more selective and patient.

Scan for slumping players and apply program

In practice, this program could be run on any given day to identify struggling players across the Reds organization. While not every slump can be explained by the approach metrics used, this can be used to easily identify and diagnose many slumps.

# Create a function to check which players are in a slump on a given date

check_slumps <- function(player_list, date) {
  
  slumping_players <- c()
  
  for(player in player_list) {
    
    if (as.Date(date) %in% get_slump_dates(player)) {
      # add player to slumping_players vector
      slumping_players <- c(slumping_players, player)
    }
    # else do nothing
  }
            
  return(slumping_players)
  
}

Example: The program is run on 09/24/2023

# For demonstration, scan all Reds MLB players from 2023
players <- unique(reds_data$player_name)

slump_list <- check_slumps(players, '2023-09-24')

slump_list
## [1] "Fraley, Jake"

At this point in time, the program identifies Jake Fraley as the only slumping player. Across an entire organization, the program can be expected to identify several players every day.

Now, the slump_comps() function can be applied to the identified player(s).

Jake Fraley

slump_comps(slump_list[1], '2023-09-24')
##                   Metric Slump Season
## 1         Pitches per PA  3.85   3.76
## 2          Chase Rate BB  0.28   0.33
## 3        Pull Percentage  0.65   0.67
## 4        Oppo Percentage  0.35   0.33
## 5 First Pitch Swing Rate  0.38   0.38