{"metadata":{"kernelspec":{"name":"ir","display_name":"R","language":"R"},"language_info":{"name":"R","codemirror_mode":"r","pygments_lexer":"r","mimetype":"text/x-r-source","file_extension":".r","version":"4.0.5"}},"nbformat_minor":4,"nbformat":4,"cells":[{"cell_type":"code","source":"## Exploratory Data Analysis & Cleaning \n## Tyler Sanders\n## 2021-10-15\n\n# Setup -------------------------------------------------------------------\n\nlibrary(tidyverse)\nlibrary(here)\nlibrary(janitor)\nlibrary(lubridate)\n\n\n# Read in Data ------------------------------------------------------------\n\ngames <- \"../input/nfl-big-data-bowl-2022/games.csv\" %>% \n  read_csv() %>% \n  clean_names()\n\npff_scouting_data <- here(\"../input/nfl-big-data-bowl-2022/PFFScoutingData.csv\") %>% \n  read_csv() %>% \n  clean_names()\n\n\nplayers <- here(\"../input/nfl-big-data-bowl-2022/players.csv\") %>% \n  read_csv() %>% \n  clean_names()\n\n\nplays <- here(\"../input/nfl-big-data-bowl-2022/plays.csv\") %>% \n  read_csv() %>% \n  clean_names()\n\n\ntracking_18 <- here(\"../input/nfl-big-data-bowl-2022/tracking2018.csv\") %>% \n  read_csv() %>% \n  clean_names()\n\n\ntracking_19 <- here(\"../input/nfl-big-data-bowl-2022/tracking2019.csv\") %>% \n  read_csv() %>% \n  clean_names()\n\n\ntracking_20 <- here(\"../input/nfl-big-data-bowl-2022/tracking2020.csv\") %>% \n  read_csv() %>% \n  clean_names()\n\n#loading data from Lee Sharpe's public GitHub repository. It includes info on field surface.\n#games_lee_sharpe <- read_csv(\"https://raw.githubusercontent.com/nflverse/nfldata/master/data/games.csv\",\n#                              col_types = cols())\n\n\n\n# Identify Injured Players ------------------------------------------------\n\n\ninjury_on_play <- plays %>% \n  filter(str_detect(play_description, \"injured\")) \n\n\ninjured_player_names <- unlist(strsplit(injury_on_play$play_description, \"(?<=[[:punct:]])\\\\s(?=[A-Z])\", perl=T)) %>% \n  enframe() %>% \n  filter(str_detect(value, \"was injured during the play.\")) %>% \n  mutate(team_of_injured_player = str_extract(value, \"[^-]+\")) %>% \n  mutate(injured_player = str_extract(value,\"(?<=-).+(?= )\")) %>% \n  rowwise() %>% \n  mutate(injured_player = strsplit(injured_player, \" \")[[1]][[1]]) %>% \n  select(team_of_injured_player, injured_player)\n  \ninjury_stats <- injury_on_play %>% \n  bind_cols(injured_player_names) \n\nplays_with_injury_data <- left_join(plays, injury_stats) %>% \n  mutate(injury_on_play_flag = case_when(is.na(injured_player) ~ 0, TRUE ~ 1))\n\nplayers_names_improved <- players %>% \n  mutate(first_name = str_extract(display_name, \"[A-Za-z]+(?=\\\\s)\"),\n         last_name  = str_remove(display_name, \"^\\\\S+\\\\s+\"),\n         first_initial = str_sub(first_name, start = 1L, end = 1L),\n         abbr_name     = paste0(first_initial, \".\", last_name))\n\ninjured_players <- plays_with_injury_data %>% \n  filter(injury_on_play_flag %in% 1) %>% \n  left_join(y = players_names_improved, by = c(\"injured_player\" = \"abbr_name\"))\n\n\ntracking_18 <- tracking_18 %>% \n  mutate(first_name    = str_extract(display_name, \"[A-Za-z]+(?=\\\\s)\"),\n         last_name     = str_remove(display_name, \"^\\\\S+\\\\s+\"),\n         first_initial = str_sub(first_name, start = 1L, end = 1L),\n         abbr_name     = paste0(first_initial, \".\", last_name))\n\n\ntracking_19 <- tracking_19 %>%\n  mutate(first_name = str_extract(display_name, \"[A-Za-z]+(?=\\\\s)\"),\n         last_name  = str_remove(display_name, \"^\\\\S+\\\\s+\"),\n         first_initial = str_sub(first_name, start = 1L, end = 1L),\n         abbr_name     = paste0(first_initial, \".\", last_name))\n\ntracking_20 <- tracking_20 %>%\n  mutate(first_name = str_extract(display_name, \"[A-Za-z]+(?=\\\\s)\"),\n         last_name  = str_remove(display_name, \"^\\\\S+\\\\s+\"),\n         first_initial = str_sub(first_name, start = 1L, end = 1L),\n         abbr_name     = paste0(first_initial, \".\", last_name))\n\n\n# Create blank tibble for function data store\nfunction_output_df <- tribble(~\"nfl_id\", ~\"display_name\", ~\"game_id\", ~\"play_id\", ~\"abbr_name\",\n                              NA_real_,     \"\",         NA_real_,  NA_real_,       \"\")\n\nlocate_injured_player_id <- function(row_num){\n\n  rm(data_search_18, data_search_19, data_search_20)\n  \n  data_search_18 <- tracking_18 %>% \n    filter(game_id %in% injured_players$game_id[[row_num]] & play_id %in% injured_players$play_id[[row_num]]) %>% \n    select(nfl_id, display_name, game_id, play_id, abbr_name) %>% \n    filter(abbr_name %in% injured_players$injured_player[[row_num]]) %>% \n    distinct()\n  \n  if(! nrow(data_search_18) %in% 1){\n  data_search_19 <- tracking_19 %>% \n    filter(game_id %in% injured_players$game_id[[row_num]] & play_id %in% injured_players$play_id[[row_num]]) %>% \n    select(nfl_id, display_name, game_id, play_id, abbr_name) %>% \n    filter(abbr_name %in% injured_players$injured_player[[row_num]]) %>% \n    distinct()\n  }\n  \n  if(exists(\"data_search_19\")){\n  if(! nrow(data_search_19) %in% 1){\n  \n  data_search_20 <- tracking_20 %>% \n    filter(game_id %in% injured_players$game_id[[row_num]] & play_id %in% injured_players$play_id[[row_num]]) %>% \n    select(nfl_id, display_name, game_id, play_id, abbr_name) %>% \n    filter(abbr_name %in% injured_players$injured_player[[row_num]]) %>% \n    distinct()\n  }\n  }\n  if(nrow(data_search_18) %in% 1){\n    temp <<- data_search_18\n  }\n  \n  if(exists(\"data_search_19\")){\n    if(nrow(data_search_19) %in% 1){\n    temp <<- data_search_19\n  }\n  }\n\n  if(exists(\"data_search_20\")){\n    if(nrow(data_search_20) %in% 1){\n      temp <<- data_search_20\n    }\n  }\n  \n  print(row_num)\n  \n  if(nrow(temp == 1)){\n    \n  function_output_df <<- bind_rows(function_output_df, temp)}\n  \n  \n\n  \n  \n}\n\n# Walk/Run Injured Player Iteration \n{\ntictoc::tic()\ninjured_players$injured_player %>% \n  enframe() %>% \n  pull(name) %>% \n  walk(locate_injured_player_id)\ntictoc::toc()\n}\n\n#Filter result to remove football \ninjured_player_ids <- function_output_df %>% \n  filter(!is.na(nfl_id)) %>% \n  distinct()\n\n\n# Plan --------------------------------------------------------------------\nffunction\n\n# How Does This Work? \n\n# Goal, use a training set of special team injuries on kickoffs and punts\n# to identify injury risk factors and model injury risk at the player level on a per-play basis\n\n# What I Have\n## Play tracking data from 2018-2020\n## PFF Scouting Data for plays 2018-2020\n## Dataset of all Special Teams NFL players 2018-2020\n## Dataset of all plays 2018-2020\n\n# How They Attach \n# The Plays dataset has a playDescription column which lists the last name and first initial of an injured player\n# By iterating over tracking data I can use play and game Ids along with name info to find the nflId of each injured player\n# I can use nflId to connect the plays, players, tracking, and scouting data \n# Create a dataframe where each row is a unique set of play and player where the columns are a combination of:\n# -play data (repetitive for each player in on that play: quarter, game closeness, play type), \n# -player data (repetitive for each play the player was on the field for: position, age, weight)\n# -player tracking data features (max acceleration, distance covered, number of pivots?, tackles?) \n\n# To Do\n\n## Load in Data [+]\n## Identify injuries [+]\n## Connect injured players/plays to tracking [+]\n## Feature selection for tracking and scouting []\n\n# tracking_18 %>% head(100) %>% view()\n# \n# avg_accel_pop <- mean(tracking_18_features$avg_acceleration)\n# avg_speed_pop <- mean(tracking_18_features$avg_speed)\n# \n# tracking_18 %>% \n#   filter(gameId %in% 2018123000, playId %in% 36, frameId %in% 12) %>% \n#   filter(displayName %in% \"Maxx Williams\") %>% \n#   pull(y)\n# \n\n  \n  \n\n# Cleaning & Feature Selection --------------------------------------------\n\nplay_data_combined <- pff_scouting_data %>% \n  full_join(y = plays, by = c(\"game_id\", \"play_id\")) %>% \n  mutate(kick_intended_achieved = case_when(kick_direction_intended %in% kick_direction_actual & ! is.na(kick_direction_actual) ~ 1, TRUE ~ 0),\n         return_intended_achieved = case_when(return_direction_intended %in% return_direction_actual & ! is.na(return_direction_actual) ~ 1, TRUE ~ 0),\n         above_average_snap_time  = case_when(snap_time > mean(snap_time) ~ 1, TRUE ~ 0),\n         above_average_operation_time = case_when(operation_time > mean(operation_time) ~ 1, TRUE ~ 0),\n         penalty_on_play              = case_when(! is.na(penalty_codes) ~ 1, TRUE ~ 0),\n         home_team_pt_dif             = pre_snap_home_score - pre_snap_visitor_score,\n         kick_returned                = case_when(! is.na(kick_return_yardage) ~ 1, TRUE ~ 0)\n         \n         \n         #figure out adding player action/position flags by number\n  )\n\ncreate_data_combined <- function(year){\n\n  if(year %in% 18){\n  tracking <- tracking_18\n  }\n  \n  if(year %in% 19){\n    tracking <- tracking_19\n  }\n  \n  if(year %in% 20){\n    tracking <- tracking_20\n  }\n  \n  \n  \ntracking_features <- tracking %>% \n  filter(! is.na(nfl_id)) %>% \n  group_by(game_id, play_id, nfl_id, display_name) %>% \n  mutate(change_direction = dir - lag(dir),\n         change_acceleration = a - lag(a),\n         quickest_slowdown = min(change_acceleration),\n         pivots           = case_when(change_direction > abs(45) ~ 1, TRUE ~ 0),\n         high_acceleration_pivots = case_when(pivots %in% 1 & a >= (5) ~ 1, TRUE ~ 0),\n         high_speed_pivots = case_when(pivots %in% 1 & a >= (5) ~ 1, TRUE ~ 0),\n         high_speed_frames = case_when(s >= (5) ~ 1, TRUE ~ 0), \n         double_moves     = case_when(pivots %in% 1 & lag(pivots) %in% 1 ~ 1, TRUE ~ 0),\n         lateral_distance = max(y) - min(y),\n         sideline_to_sideline = case_when(max(y) > (53.3-5) & min(y) < 5 ~ 1, TRUE ~ 0),\n         cross_lateral_midfield = case_when(max(y) > (53.3 / 2) & min(y) > (53.2 / 2) |\n                                            max(y) < (53.3 / 2) & min(y) < (53.2 / 2) ~ 1, TRUE ~ 0)) %>%\n  #na.omit() %>% \n  summarise(avg_speed = mean(s),\n            min_speed = min(s),\n            max_speed = max(s),\n            min_acceleration = min(a),\n            avg_acceleration = mean(a),\n            max_acceleration = max(a),\n            quickest_slowdown = quickest_slowdown,\n            total_distance = sum(dis),\n            home = team,\n            jersey_number = jersey_number, \n            position = position,\n            pivots_total = sum(pivots), \n            high_acceleration_pivots_total = sum(high_acceleration_pivots),\n            high_speed_pivots_total = sum(high_speed_pivots),\n            high_speed_frames = sum(high_speed_frames),\n            double_moves = double_moves,\n            lateral_distance = lateral_distance,\n            starting_x = first(x),\n            starting_y = first(y),\n            sideline_to_sideline = sideline_to_sideline,\n            cross_lateral_midfield = cross_lateral_midfield\n            \n            #Initial sprint is 40 frames\n            \n            \n            #distance from football\n            #Number of players within x proximity \n            \n            ) %>% \n  distinct(game_id, play_id, nfl_id, .keep_all = TRUE)\n  \ninjured_eda_with_tracking <- tracking_features %>% \n  left_join(injured_player_ids, by = c(\"game_id\", \"play_id\", \"nfl_id\", \"display_name\")) %>% \n  mutate(injured = case_when(! is.na(abbr_name) ~ 1, TRUE ~0)) %>%\n  distinct()\n\n\ndata_combined <- injured_eda_with_tracking %>% \n  left_join(y = games, by = \"game_id\") %>% \n  left_join(y = players, by = c(\"nfl_id\", \"display_name\")) %>% \n  left_join(y = play_data_combined, by = c(\"game_id\", \"play_id\")) %>% \n  mutate(team_name               = case_when(home %in% \"home\" ~ home_team_abbr, TRUE ~ visitor_team_abbr),\n         jersey_number           = case_when(jersey_number %in% c(0:9) ~ paste0(as.character(jersey_number), \" \"),\n                                                                  TRUE ~ as.character(jersey_number)),\n         player_team             = paste(team_name, jersey_number),\n         is_gunner               = case_when(str_detect(gunners, player_team) ~ 1, TRUE ~ 0),\n         is_punt_rusher          = case_when(str_detect(punt_rushers, player_team) ~ 1, TRUE ~ 0),\n         is_punt_rusher          = case_when(str_detect(punt_rushers, player_team) ~ 1, TRUE ~ 0),\n         is_special_teams_safety = case_when(str_detect(special_teams_safeties, player_team) ~ 1, TRUE ~ 0),\n         is_missed_tackler       = case_when(str_detect(missed_tackler, player_team) ~ 1, TRUE ~ 0),\n         is_assist_tackler       = case_when(str_detect(assist_tackler, player_team) ~ 1, TRUE ~ 0),\n         is_tackler              = case_when(str_detect(tackler, player_team) ~ 1, TRUE ~ 0),\n         is_vises                = case_when(str_detect(vises, player_team) ~ 1, TRUE ~ 0),\n         is_returner             = case_when(nfl_id %in% returner_id ~ 1, TRUE ~ 0),\n         called_for_penalty      = case_when(str_detect(penalty_jersey_numbers, player_team) ~ 1, TRUE ~ 0),\n         season_quarter = case_when(week %in% c(1:4)   ~  \"First\",\n                                    week %in% c(5:8)   ~ \"Second\", \n                                    week %in% c(9:12)  ~  \"Third\",\n                                    week %in% c(13:17) ~  \"Last\"),\n         game_time_slot = case_when(game_time_eastern < hms(\"16:05:00\")                                     ~     \"Early\",\n                                    game_time_eastern > hms(\"16:05:00\") & game_time_eastern < hms(\"19:10:00\") ~ \"Afternoon\",\n                                    TRUE                                                                  ~    \"Night\")) %>% \n  ungroup()\n\n\n}\n\n{\ntictoc::tic()\ndata_combined_18 <- create_data_combined(year = 18)\ntictoc::toc()\n} #14 minutes 20 seconds\n\n{\ntictoc::tic()\ndata_combined_19 <- create_data_combined(year = 19)\ntictoc::toc() # 13 minutes 8 seconds\n}\n\n{\n  tictoc::tic()\ndata_combined_20 <- create_data_combined(year = 20)\ntictoc::toc() # 13 minutes 12 seconds\n}\n\ndata_combined_final <- bind_rows(data_combined_18, data_combined_19, data_combined_20)\n\n# Player Proximity --------------------------------------------------------\n\n\nplayer_proximity <- tribble(~\"game_id\", ~\"play_id\", ~\"nfl_id\", ~\"engaged_player_count\", ~\"close_player_count\",\n                                 ~\"max_engaged\", ~\"max_close\", ~\"longest_engaged\", ~\"longest_close\", ~\"per_frames_engaged\", ~\"per_frames_close\",\n                              NA_real_, NA_real_, NA_real_, NA_real_, NA_real_, NA_real_, NA_real_, NA_real_, NA_real_, NA_real_, NA_real_)\n\n\n\ncalculate_player_proximity_18 <- function(row_num){\n\n  primary_player_df <- primary_player_df_18\n  \nopposing_player_df <- tracking_18 %>%\n  filter(game_id %in% primary_player_df$game_id[[row_num]] & play_id %in% primary_player_df$play_id[[row_num]] &\n        !nfl_id %in% primary_player_df$nfl_id[[row_num]]) %>% \n  filter(!team %in% primary_player_df$home[[row_num]] & ! is.na(nfl_id)) %>%\n  select(nfl_id, frame_id, x, y)\n\nprimary_player_frames <- tracking_18 %>% \n  filter(game_id %in% primary_player_df$game_id[[row_num]], play_id %in% primary_player_df$play_id[[row_num]],\n         nfl_id %in% primary_player_df$nfl_id[[row_num]]) %>% \n  mutate(primary_nfl_id = nfl_id,\n         primary_x = x,\n         primary_y = y) %>% \n  select(-nfl_id, -x, -y)\n\ntemp <- opposing_player_df %>%\n  left_join(y = primary_player_frames, by = c(\"frame_id\")) %>%\n  rowwise() %>%\n  mutate(opponent_engaged = case_when(abs(primary_x - x) < .5 & abs(primary_y - y) < .5 ~ 1, TRUE ~ 0),\n         opponent_close   = case_when(abs(primary_x - x) <  3 & abs(primary_y - y) <  3 ~ 1, TRUE ~ 0)) \n\n\n\nengaged_player_calc <- temp %>%\n  group_by(primary_nfl_id, game_id, play_id, nfl_id) %>%\n  summarise(engaged_player_count = case_when(sum(opponent_engaged) > 0 ~ 1, TRUE ~ 0)) %>%\n  ungroup() %>%\n  mutate(engaged_player_count = sum(engaged_player_count)) %>%\n  select(game_id, play_id, primary_nfl_id, engaged_player_count) %>%\n  slice(1)\n\nmax_engaged_calc <- temp %>%\n  group_by(primary_nfl_id, frame_id) %>%\n  summarise(max_engaged = sum(opponent_engaged)) %>%\n  ungroup() %>%\n  arrange(desc(max_engaged)) %>%\n  select(primary_nfl_id, max_engaged) %>%\n  slice(1)\n\nlongest_engaged_calc <- temp %>%\n  group_by(primary_nfl_id, nfl_id) %>%\n  summarise(longest_engaged = sum(opponent_engaged)) %>%\n  ungroup() %>%\n  arrange(desc(longest_engaged)) %>%\n  select(primary_nfl_id, longest_engaged) %>%\n  slice(1)\n\nframes_engaged_calc <- temp %>%\n  group_by(primary_nfl_id, frame_id) %>%\n  summarise(engaged_frame = case_when(sum(opponent_engaged) > 0 ~ 1, TRUE ~ 0)) %>%\n  summarise(per_frames_engaged = sum(engaged_frame) / max(temp$frame_id))\n\nclose_player_calc <- temp %>%\n  group_by(primary_nfl_id, nfl_id) %>%\n  summarise(close_player_count = case_when(sum(opponent_close) > 0 ~ 1, TRUE ~ 0)) %>%\n  ungroup() %>%\n  mutate(close_player_count = sum(close_player_count)) %>%\n  select(primary_nfl_id, close_player_count) %>%\n  slice(1)\n\nmax_close_calc <- temp %>%\n  group_by(primary_nfl_id, frame_id) %>%\n  summarise(max_close = sum(opponent_close)) %>%\n  ungroup() %>%\n  arrange(desc(max_close)) %>%\n  select(primary_nfl_id, max_close) %>%\n  slice(1)\n\nlongest_close_calc <- temp %>%\n  group_by(primary_nfl_id, nfl_id) %>%\n  summarise(longest_close = sum(opponent_close)) %>%\n  ungroup() %>%\n  arrange(desc(longest_close)) %>%\n  select(primary_nfl_id, longest_close) %>%\n  slice(1)\n\nframes_close_calc <- temp %>%\n  group_by(primary_nfl_id, frame_id) %>%\n  summarise(close_frame = case_when(sum(opponent_close) > 0 ~ 1, TRUE ~ 0)) %>%\n  summarise(per_frames_close = sum(close_frame) / max(temp$frame_id))\n\nintermediate <<- engaged_player_calc %>%\n  left_join(close_player_calc,    by = \"primary_nfl_id\") %>%\n  left_join(max_engaged_calc,     by = \"primary_nfl_id\") %>%\n  left_join(max_close_calc,       by = \"primary_nfl_id\") %>%\n  left_join(longest_engaged_calc, by = \"primary_nfl_id\") %>%\n  left_join(longest_close_calc,   by = \"primary_nfl_id\") %>%\n  left_join(frames_engaged_calc,  by = \"primary_nfl_id\") %>%\n  left_join(frames_close_calc,    by = \"primary_nfl_id\") %>%\n  select(game_id, play_id, nfl_id = primary_nfl_id,  everything())\n  \n\nprint(row_num)\n\n  player_proximity <<- bind_rows(player_proximity, intermediate)\n}\n\ncalculate_player_proximity_19 <- function(row_num){\n  \n  primary_player_df <- primary_player_df_19\n  \n  opposing_player_df <- tracking_19 %>%\n    filter(game_id %in% primary_player_df$game_id[[row_num]] & play_id %in% primary_player_df$play_id[[row_num]] &\n             !nfl_id %in% primary_player_df$nfl_id[[row_num]]) %>% \n    filter(!team %in% primary_player_df$home[[row_num]] & ! is.na(nfl_id)) %>%\n    select(nfl_id, frame_id, x, y)\n  \n  primary_player_frames <- tracking_19 %>% \n    filter(game_id %in% primary_player_df$game_id[[row_num]], play_id %in% primary_player_df$play_id[[row_num]],\n           nfl_id %in% primary_player_df$nfl_id[[row_num]]) %>% \n    mutate(primary_nfl_id = nfl_id,\n           primary_x = x,\n           primary_y = y) %>% \n    select(-nfl_id, -x, -y)\n  \n  temp <- opposing_player_df %>%\n    left_join(y = primary_player_frames, by = c(\"frame_id\")) %>%\n    rowwise() %>%\n    mutate(opponent_engaged = case_when(abs(primary_x - x) < .5 & abs(primary_y - y) < .5 ~ 1, TRUE ~ 0),\n           opponent_close   = case_when(abs(primary_x - x) <  3 & abs(primary_y - y) <  3 ~ 1, TRUE ~ 0)) \n  \n  \n  \n  engaged_player_calc <- temp %>%\n    group_by(primary_nfl_id, game_id, play_id, nfl_id) %>%\n    summarise(engaged_player_count = case_when(sum(opponent_engaged) > 0 ~ 1, TRUE ~ 0)) %>%\n    ungroup() %>%\n    mutate(engaged_player_count = sum(engaged_player_count)) %>%\n    select(game_id, play_id, primary_nfl_id, engaged_player_count) %>%\n    slice(1)\n  \n  max_engaged_calc <- temp %>%\n    group_by(primary_nfl_id, frame_id) %>%\n    summarise(max_engaged = sum(opponent_engaged)) %>%\n    ungroup() %>%\n    arrange(desc(max_engaged)) %>%\n    select(primary_nfl_id, max_engaged) %>%\n    slice(1)\n  \n  longest_engaged_calc <- temp %>%\n    group_by(primary_nfl_id, nfl_id) %>%\n    summarise(longest_engaged = sum(opponent_engaged)) %>%\n    ungroup() %>%\n    arrange(desc(longest_engaged)) %>%\n    select(primary_nfl_id, longest_engaged) %>%\n    slice(1)\n  \n  frames_engaged_calc <- temp %>%\n    group_by(primary_nfl_id, frame_id) %>%\n    summarise(engaged_frame = case_when(sum(opponent_engaged) > 0 ~ 1, TRUE ~ 0)) %>%\n    summarise(per_frames_engaged = sum(engaged_frame) / max(temp$frame_id))\n  \n  close_player_calc <- temp %>%\n    group_by(primary_nfl_id, nfl_id) %>%\n    summarise(close_player_count = case_when(sum(opponent_close) > 0 ~ 1, TRUE ~ 0)) %>%\n    ungroup() %>%\n    mutate(close_player_count = sum(close_player_count)) %>%\n    select(primary_nfl_id, close_player_count) %>%\n    slice(1)\n  \n  max_close_calc <- temp %>%\n    group_by(primary_nfl_id, frame_id) %>%\n    summarise(max_close = sum(opponent_close)) %>%\n    ungroup() %>%\n    arrange(desc(max_close)) %>%\n    select(primary_nfl_id, max_close) %>%\n    slice(1)\n  \n  longest_close_calc <- temp %>%\n    group_by(primary_nfl_id, nfl_id) %>%\n    summarise(longest_close = sum(opponent_close)) %>%\n    ungroup() %>%\n    arrange(desc(longest_close)) %>%\n    select(primary_nfl_id, longest_close) %>%\n    slice(1)\n  \n  frames_close_calc <- temp %>%\n    group_by(primary_nfl_id, frame_id) %>%\n    summarise(close_frame = case_when(sum(opponent_close) > 0 ~ 1, TRUE ~ 0)) %>%\n    summarise(per_frames_close = sum(close_frame) / max(temp$frame_id))\n  \n  intermediate <<- engaged_player_calc %>%\n    left_join(close_player_calc,    by = \"primary_nfl_id\") %>%\n    left_join(max_engaged_calc,     by = \"primary_nfl_id\") %>%\n    left_join(max_close_calc,       by = \"primary_nfl_id\") %>%\n    left_join(longest_engaged_calc, by = \"primary_nfl_id\") %>%\n    left_join(longest_close_calc,   by = \"primary_nfl_id\") %>%\n    left_join(frames_engaged_calc,  by = \"primary_nfl_id\") %>%\n    left_join(frames_close_calc,    by = \"primary_nfl_id\") %>%\n    select(game_id, play_id, nfl_id = primary_nfl_id,  everything())\n  \n  \n  print(row_num)\n  \n  player_proximity <<- bind_rows(player_proximity, intermediate)\n}\n\ncalculate_player_proximity_20 <- function(row_num){\n  \n  primary_player_df <- primary_player_df_20\n  \n  opposing_player_df <- tracking_20 %>%\n    filter(game_id %in% primary_player_df$game_id[[row_num]] & play_id %in% primary_player_df$play_id[[row_num]] &\n             !nfl_id %in% primary_player_df$nfl_id[[row_num]]) %>% \n    filter(!team %in% primary_player_df$home[[row_num]] & ! is.na(nfl_id)) %>%\n    select(nfl_id, frame_id, x, y)\n  \n  primary_player_frames <- tracking_20 %>% \n    filter(game_id %in% primary_player_df$game_id[[row_num]], play_id %in% primary_player_df$play_id[[row_num]],\n           nfl_id %in% primary_player_df$nfl_id[[row_num]]) %>% \n    mutate(primary_nfl_id = nfl_id,\n           primary_x = x,\n           primary_y = y) %>% \n    select(-nfl_id, -x, -y)\n  \n  temp <- opposing_player_df %>%\n    left_join(y = primary_player_frames, by = c(\"frame_id\")) %>%\n    rowwise() %>%\n    mutate(opponent_engaged = case_when(abs(primary_x - x) < .5 & abs(primary_y - y) < .5 ~ 1, TRUE ~ 0),\n           opponent_close   = case_when(abs(primary_x - x) <  3 & abs(primary_y - y) <  3 ~ 1, TRUE ~ 0)) \n  \n  \n  \n  engaged_player_calc <- temp %>%\n    group_by(primary_nfl_id, game_id, play_id, nfl_id) %>%\n    summarise(engaged_player_count = case_when(sum(opponent_engaged) > 0 ~ 1, TRUE ~ 0)) %>%\n    ungroup() %>%\n    mutate(engaged_player_count = sum(engaged_player_count)) %>%\n    select(game_id, play_id, primary_nfl_id, engaged_player_count) %>%\n    slice(1)\n  \n  max_engaged_calc <- temp %>%\n    group_by(primary_nfl_id, frame_id) %>%\n    summarise(max_engaged = sum(opponent_engaged)) %>%\n    ungroup() %>%\n    arrange(desc(max_engaged)) %>%\n    select(primary_nfl_id, max_engaged) %>%\n    slice(1)\n  \n  longest_engaged_calc <- temp %>%\n    group_by(primary_nfl_id, nfl_id) %>%\n    summarise(longest_engaged = sum(opponent_engaged)) %>%\n    ungroup() %>%\n    arrange(desc(longest_engaged)) %>%\n    select(primary_nfl_id, longest_engaged) %>%\n    slice(1)\n  \n  frames_engaged_calc <- temp %>%\n    group_by(primary_nfl_id, frame_id) %>%\n    summarise(engaged_frame = case_when(sum(opponent_engaged) > 0 ~ 1, TRUE ~ 0)) %>%\n    summarise(per_frames_engaged = sum(engaged_frame) / max(temp$frame_id))\n  \n  close_player_calc <- temp %>%\n    group_by(primary_nfl_id, nfl_id) %>%\n    summarise(close_player_count = case_when(sum(opponent_close) > 0 ~ 1, TRUE ~ 0)) %>%\n    ungroup() %>%\n    mutate(close_player_count = sum(close_player_count)) %>%\n    select(primary_nfl_id, close_player_count) %>%\n    slice(1)\n  \n  max_close_calc <- temp %>%\n    group_by(primary_nfl_id, frame_id) %>%\n    summarise(max_close = sum(opponent_close)) %>%\n    ungroup() %>%\n    arrange(desc(max_close)) %>%\n    select(primary_nfl_id, max_close) %>%\n    slice(1)\n  \n  longest_close_calc <- temp %>%\n    group_by(primary_nfl_id, nfl_id) %>%\n    summarise(longest_close = sum(opponent_close)) %>%\n    ungroup() %>%\n    arrange(desc(longest_close)) %>%\n    select(primary_nfl_id, longest_close) %>%\n    slice(1)\n  \n  frames_close_calc <- temp %>%\n    group_by(primary_nfl_id, frame_id) %>%\n    summarise(close_frame = case_when(sum(opponent_close) > 0 ~ 1, TRUE ~ 0)) %>%\n    summarise(per_frames_close = sum(close_frame) / max(temp$frame_id))\n  \n  intermediate <<- engaged_player_calc %>%\n    left_join(close_player_calc,    by = \"primary_nfl_id\") %>%\n    left_join(max_engaged_calc,     by = \"primary_nfl_id\") %>%\n    left_join(max_close_calc,       by = \"primary_nfl_id\") %>%\n    left_join(longest_engaged_calc, by = \"primary_nfl_id\") %>%\n    left_join(longest_close_calc,   by = \"primary_nfl_id\") %>%\n    left_join(frames_engaged_calc,  by = \"primary_nfl_id\") %>%\n    left_join(frames_close_calc,    by = \"primary_nfl_id\") %>%\n    select(game_id, play_id, nfl_id = primary_nfl_id,  everything())\n  \n  \n  print(row_num)\n  \n  player_proximity <<- bind_rows(player_proximity, intermediate)\n}\n\nprimary_player_df_18 <- data_combined_18 %>%\n  filter(is_returner %in% 1 & special_teams_result %in% \"Return\") %>%\n  distinct(game_id, play_id, nfl_id, home)\n\n{\ntictoc::tic()\nprimary_player_df_18$nfl_id %>% \n  enframe() %>% \n  pull(name) %>% \n  walk(calculate_player_proximity_18)\ntictoc::toc()\n} \n\nprimary_player_df_19 <- data_combined_19 %>%\n  filter(is_returner %in% 1 & special_teams_result %in% \"Return\") %>%\n  distinct(game_id, play_id, nfl_id, home)\n\n{\n  tictoc::tic()\n  primary_player_df_19$nfl_id %>% \n    enframe() %>% \n    pull(name) %>% \n    walk(calculate_player_proximity_19)\n  tictoc::toc()\n  }\n\nprimary_player_df_20 <- data_combined_20 %>%\n  filter(is_returner %in% 1 & special_teams_result %in% \"Return\") %>%\n  distinct(game_id, play_id, nfl_id, home)\n\n{\n  tictoc::tic()\n  primary_player_df_20$nfl_id %>% \n    enframe() %>% \n    pull(name) %>% \n    walk(calculate_player_proximity_20)\n  tictoc::toc()\n  }\n\n\nplayer_proximity_final <- player_proximity %>% \n  filter(! is.na(nfl_id)) \n\n\nfull_sample_returns <- player_proximity_final %>% \n  left_join(y = data_combined_final, by = c(\"game_id\", \"play_id\", \"nfl_id\"))\n\ntraining_set_returns <- full_sample_returns %>% \n  filter(injured %in% 1)\n\n\nfull_sample_returns %>% \n   write_csv(\"data/kick_returns.csv\")\n\n\n## Create population modeling set [+]\n## Complete first draft final modeling set []\n## Expand population modeling set with feature selection [Never over]\n## Model Research []\n## Write Model Code [] \n## Review Model Quality []\n## Visualize Results []\n## Write-up Report [] \n \n\n###### End of EDA Section #########\n\n## Model Returner Injuries \n## Tyler Sanders\n## 7-11-2021\n\n\n# Setup -------------------------------------------------------------------\nlibrary(tidyverse)\nlibrary(tidymodels)\nlibrary(vip)\nlibrary(themis)\nlibrary(workflows)\nlibrary(janitor)\nlibrary(kableExtra)\n\n# Load Data ---------------------------------------------------------------\n\n## Load and wrangle initial modeling data\nkick_returners <- read_csv(here::here(\"data/kick_returns.csv\")) %>% \n  select(-special_teams_result, -c(week, play_result, min_speed, visitor_team_abbr, possession_team, jersey_number, play_description, game_date, team_name, returner_id, game_clock, yardline_number, quickest_slowdown, double_moves, kick_blocker_id, pass_result, above_average_snap_time, above_average_operation_time, is_gunner, is_punt_rusher, is_special_teams_safety, is_missed_tackler, is_assist_tackler, is_tackler, is_vises, is_returner, abbr_name, pre_snap_home_score, pre_snap_visitor_score, kicker_id, player_team, home_team_abbr, birth_date, college_name, position.y, snap_detail, snap_time, operation_time, hang_time, kick_direction_intended, kick_direction_actual, return_direction_intended, return_direction_actual, missed_tackler, assist_tackler, tackler, kickoff_return_formation, gunners, punt_rushers, special_teams_safeties, vises, kick_contact_type, yardline_side, penalty_codes, penalty_jersey_numbers, penalty_yards, kick_return_yardage)) %>% \n  mutate(injured = case_when(injured %in% 1 ~ \"Injured\", TRUE ~ \"Not Injured\")) %>% \n  mutate_if(is.character, as.factor) \n  \n# Create Training/Testing Sets --------------------------------------------\n\n## Set Seed by development start date \nset.seed(seed = 7112021)\n\n# Initial Modeling Split with special injured player strata \nkick_returners_split <- initial_split(kick_returners, strata = injured, pool = .001, prop = .8)\n\n# Store training split for review\ntraining_df <- training(kick_returners_split)\n\n## Model Recipe \ntraining_recipes <- recipe(injured ~ ., data = training_df) %>% \n  update_role(game_id, play_id, nfl_id, new_role = \"ID\") %>% \n  ## https://juliasilge.com/blog/sliced-aircraft/\n  #step_smote() %>% \n  #step_dummy(all_nominal_predictors()) %>% \n  step_meanimpute(all_numeric_predictors()) %>% \n  step_modeimpute(all_nominal_predictors()) %>% \n # step_zv(all_predictors()) %>% \n  prep()\n\n## Pull prepped testing and training data\ntesting_df <- testing(kick_returners_split)\ntraining_df <- juice(training_recipes)\n\n# Model Returner Injury Likelihood ----------------------------------------\n\n## Construct Engine \nranger_engine <- rand_forest(trees = 100, mode = \"classification\", mtry = 4, min_n = 1000) %>%\n  set_engine(\"ranger\", importance = \"impurity\")\n\n## Establish Workflow\nreturn_wf <- workflow() %>% \n  add_model(ranger_engine) %>% \n  add_recipe(training_recipes)\n\n## Fit prepped training data\nranger_fit <- return_wf %>% \n  fit(data = training_df)\n\n\n## Final Predictions \npred_results <- predict(ranger_fit, new_data = testing_df, type = \"prob\") %>% arrange(desc(.pred_Injured))\n\n\n## Final Results DF\ntesting_results <- bind_cols(testing_df, pred_results) \n\n\n# Model Results Review  -----------------------------------------------------------\n\n## Variable Importance Chart\nranger_fit %>% \n  extract_fit_parsnip()  %>% \n  vip(num_features = 20)\n\n## Results Histogram\nhist(pred_results$.pred_Injured)\n\n## Injured Group Validation Test \ntesting_results %>% \n  group_by(injured) %>% \n  summarise(mean(.pred_Injured))\n \n\n## Results Table\ntesting_results %>% \n  group_by(season, display_name) %>% \n  summarise(total_injury_risk = sum(.pred_Injured),\n            number_of_returns = n(),\n            avg_risk = mean(.pred_Injured)) %>% \n  arrange(desc(total_injury_risk)) %>% \n  select(season, display_name, total_injury_risk, avg_risk, number_of_returns) %>% \n  mutate(number_of_returns = scales::comma(number_of_returns, accuracy = 1)) %>% \n  mutate(across(is.numeric, scales::percent, accuracy = .01)) %>% \n  filter(season %in% 2020) %>% \n  ungroup() %>% \n  select(-season) %>% \n  head(10) %>% \n  kbl(col.names = c(\"Returner\", \"Modeled Injury Risk\", \"Injury Risk Per Return\", \"Number of Returns\"), align = c(\"r\", \"c\", \"c\", \"c\")) %>% \n  kable_classic_2() %>% \n  add_header_above(c(\"Top 10 Most At-Risk Returners: 2020 Season\" = 4), font = 12) %>% \n  add_header_above(c(\"Returner Injury Risk\" = 4), line = F) \n","metadata":{"_uuid":"051d70d956493feee0c6d64651c6a088724dca2a","_execution_state":"idle","execution":{"iopub.status.busy":"2022-01-05T04:42:50.748064Z","iopub.execute_input":"2022-01-05T04:42:50.750113Z","iopub.status.idle":"2022-01-05T04:45:27.058988Z"},"trusted":true},"execution_count":null,"outputs":[]}]}