{"cells":[{"metadata":{},"cell_type":"markdown","source":"**SETUP**\n\nHere we load libraries and create the dataset we use for analysis."},{"metadata":{"trusted":true},"cell_type":"code","source":"## Import Libraries\nlibrary(tidyverse)\nlibrary(ROSE)\nlibrary(mlr3)\nlibrary(mlr3learners)\nlibrary(mlr3measures)\nlibrary(mlr3filters)\nlibrary(paradox)\nlibrary(rpart)\nlibrary(shape)","execution_count":null,"outputs":[]},{"metadata":{"trusted":true},"cell_type":"code","source":"## Set Seed\nset.seed(15)","execution_count":null,"outputs":[]},{"metadata":{"trusted":true},"cell_type":"code","source":"## Read in Data\ninjury_record  <- read_csv(\"../input/nfl-playing-surface-analytics/InjuryRecord.csv\")\nplay_list <- read_csv(\"../input/nfl-playing-surface-analytics/PlayList.csv\")\nplayer_track_data <- read_csv(\"../input/nfl-playing-surface-analytics/PlayerTrackData.csv\")","execution_count":null,"outputs":[]},{"metadata":{"trusted":true},"cell_type":"code","source":"## Show head of injury_record\nhead(injury_record)","execution_count":null,"outputs":[]},{"metadata":{"trusted":true},"cell_type":"code","source":"## Show head of play_list\nhead(play_list)","execution_count":null,"outputs":[]},{"metadata":{"trusted":true},"cell_type":"code","source":"## Show head of player_track_data\nhead(player_track_data)","execution_count":null,"outputs":[]},{"metadata":{"trusted":true},"cell_type":"code","source":"## function that joins all nfl data tables, filters by PositionGroup and fixes features\ncreate_nfl_data <- function(position_group = \"ALL\", balance = TRUE) {\n  \n  # function that makes StadiumType one of open, closed or unknown\n  fix_stadium_type <- function(x) {\n    open <- c('Outdoor', 'Outdoors', 'Cloudy', 'Heinz Field', \n              'Outdor', 'Ourdoor', 'Outside', 'Outddors', \n              'Outdoor Retr Roof-Open', 'Oudoor', 'Bowl', 'Indoor, Open Roof', \n              'Open', 'Retr. Roof-Open', 'Retr. Roof - Open', \n              'Domed, Open', 'Domed, open')\n    \n    closed <- c('Indoors', 'Indoor', 'Indoor, Roof Closed', 'Indoor, Roof Closed',\n                'Retractable Roof', 'Retr. Roof-Closed', 'Retr. Roof - Closed', 'Retr. Roof Closed',\n                'Dome', 'Domed, closed', 'Closed Dome', 'Domed', 'Dome, closed')\n    \n    if(x %in% open) {\n      \"open\"\n    } else if (x %in% closed) {\n      \"closed\"\n    } else {\n      \"unknown\"\n    }\n  }\n  \n  # function that makes Weather one of no precipitation, rain, snow or unknown\n  fix_weather <- function(x) {\n    no_precipitation <- c('Partly clear', 'Sunny and clear', 'Sun & clouds', 'Clear and Sunny',\n                          'Sunny and cold', 'Sunny Skies', 'Clear and Cool', 'Clear and sunny',\n                          'Sunny, highs to upper 80s', 'Mostly Sunny Skies', 'Cold',\n                          'Clear and warm', 'Sunny and warm', 'Clear and cold', 'Mostly sunny',\n                          'T: 51; H: 55; W: NW 10 mph', 'Clear Skies', 'Clear skies', 'Partly sunny',\n                          'Fair', 'Partly Sunny', 'Mostly Sunny', 'Clear', 'Sunny',\n                          'Party Cloudy', 'Cloudy, chance of rain', 'Coudy', \n                          'Cloudy and cold', 'Cloudy, fog started developing in 2nd quarter',\n                          'Partly Clouidy', 'Mostly Coudy', 'Cloudy and Cool',\n                          'cloudy', 'Partly cloudy', 'Overcast', 'Hazy', 'Mostly cloudy', 'Mostly Cloudy',\n                          'Partly Cloudy', 'Cloudy', 'N/A Indoor', 'Indoors', 'Indoor', 'N/A (Indoors)', \n                          'Controlled Climate')\n    rain <- c('30% Chance of Rain', 'Rainy', 'Rain Chance 40%', 'Showers', 'Cloudy, 50% change of rain', \n              'Rain likely, temps in low 40s.', 'Cloudy with periods of rain, thunder possible. Winds shifting to WNW, 10-20 mph.',\n              'Scattered Showers', 'Cloudy, Rain', 'Rain shower', 'Light Rain', 'Rain')\n    snow <- c('Cloudy, light snow accumulating 1-3\"', 'Heavy lake effect snow', 'Snow')\n    \n    if(x %in% no_precipitation) {\n      \"no precipitation\"\n    } else if (x %in% rain) {\n      \"rain\"\n    } else if (x %in% snow) {\n      \"snow\"\n    } else {\n      \"unknown\"\n    }\n  }\n  \n  # summarise player_track_data\n  player_track_data %>% \n    group_by(PlayKey) %>%\n    mutate(Stress = abs(o - dir) * s) %>% \n    summarise(Distance = sum(dis), Max_Stress = max(Stress)) -> ptd\n  \n  # filter play_list by PositionGroup\n  POSITION_GROUPS <- c(\"QB\", \"WR\", \"LB\", \"RB\", \"DL\", \"TE\", \"DB\", \"OL\", \"SPEC\")\n  VALID_GROUP <- is.character(position_group) && position_group %in% POSITION_GROUPS\n  \n  data <- play_list\n  if(VALID_GROUP) {\n    data <- play_list %>% filter(PositionGroup == position_group)\n  }\n  \n  # fix play_list features\n  data %>% \n    mutate(StadiumType = mapply(fix_stadium_type, StadiumType)) %>% \n    mutate(Weather = mapply(fix_weather, Weather)) %>% \n    mutate(StadiumWithWeather = ifelse(StadiumType == \"closed\", \"closed\",\n                                       ifelse(StadiumType == \"unknown\", \"unknown\",\n                                              ifelse(Weather == \"unknown\", \"unknown\",\n                                                     paste(StadiumType, \"-\", Weather))))) -> data\n  \n  # join play_list with injury_record\n  ir <- injury_record\n  ir$Injured <- \"TRUE\"\n  data <- left_join(data, ir)\n  data$Injured[is.na(data$Injured)] <- \"FALSE\"\n  \n  # select needed columns\n  if(VALID_GROUP) {\n    data %>% \n      select(-c(PlayerKey, GameID, RosterPosition, StadiumType, Weather, Position, \n                PositionGroup, BodyPart, Surface, DM_M1, DM_M7, DM_M28, DM_M42)) -> data\n  }\n  else {\n    data %>% \n      select(-c(PlayerKey, GameID, RosterPosition, StadiumType, Weather, Position, \n                BodyPart, Surface, DM_M1, DM_M7, DM_M28, DM_M42)) -> data\n    \n    data$PositionGroup <- as.factor(data$PositionGroup)\n  }\n  \n  # make category features factors\n  data$Injured <- as.factor(data$Injured)\n  data$FieldType <- as.factor(data$FieldType)\n  data$PlayType <- as.factor(data$PlayType)\n  data$StadiumWithWeather <- as.factor(data$StadiumWithWeather)\n  \n  # join with player_track_data\n  data %>% \n    inner_join(ptd) -> data\n  \n  # balance data if balance is true\n  if (balance) {\n    data <- ovun.sample(formula = Injured ~ ., data = data, \n                        method = \"both\", N = 10000, p = 0.5, seed = 15)$data\n  } \n  \n  return(data)  \n}","execution_count":null,"outputs":[]},{"metadata":{"trusted":true},"cell_type":"code","source":"## get fixed data set\nnfl_data <- create_nfl_data()","execution_count":null,"outputs":[]},{"metadata":{"trusted":true},"cell_type":"code","source":"## Show head of nfl_data\nhead(nfl_data)","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"**MODELS**\n\nWe made both a logistic regression and a tree model."},{"metadata":{"trusted":true},"cell_type":"code","source":"# create learning task\ntask_nfl <- TaskClassif$new(id = \"nfl\", backend = nfl_data[, -1], target = \"Injured\", positive = \"TRUE\")\ntask_nfl","execution_count":null,"outputs":[]},{"metadata":{"trusted":true},"cell_type":"code","source":"# set train and test indices\ntrain_idx <- sample(seq_len(task_nfl$nrow), 0.8 * task_nfl$nrow)\ntest_idx <- base::setdiff(seq_len(task_nfl$nrow), train_idx)","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"Logistic Regression"},{"metadata":{"trusted":true},"cell_type":"code","source":"# create learner\nlog_reg_learner <- lrn(\"classif.log_reg\", predict_type = \"prob\")","execution_count":null,"outputs":[]},{"metadata":{"trusted":true},"cell_type":"code","source":"# train model\nlog_reg_learner$train(task_nfl, row_ids = train_idx)","execution_count":null,"outputs":[]},{"metadata":{"trusted":true},"cell_type":"code","source":"# logistic regression model\nsummary(log_reg_learner$model)","execution_count":null,"outputs":[]},{"metadata":{"trusted":true},"cell_type":"code","source":"# predict on test set\npredictions <- log_reg_learner$predict(task_nfl, row_ids = test_idx)\npredictions$confusion\npredictions$score(msr(\"classif.acc\"))","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"Rpart Tree Model\n\nSince the kaggle kernel does not have mlr3tuning package I did the tuning externally and passed in the tuned parameters."},{"metadata":{"trusted":true},"cell_type":"code","source":"# adding externally tuned parameters\ntuned_params <- list(xval = 0, cp = 0.001, minsplit = 10)\n\n# set best parameters learned from tuning to learner\nrpart_learner <- lrn(\"classif.rpart\", predict_type = \"prob\")\nrpart_learner$param_set$values <- tuned_params\n\n# train tree\nrpart_learner$train(task = task_nfl, row_ids = train_idx)\n\n# test metrics\nrpart_predictions <- rpart_learner$predict(task = task_nfl, row_ids = test_idx)\nrpart_predictions$confusion\nrpart_predictions$score(msr(\"classif.acc\"))\nrpart_learner$model$variable.importance","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"**Descriptive Stats**"},{"metadata":{"trusted":true},"cell_type":"code","source":"# Join Data\ndata1<-left_join(injury_record,play_list, by=c(\"PlayerKey\",\"GameID\",\"PlayKey\"))# Keeps only those on injury record\ndata<-left_join(data1,player_track_data)  # Only injured players\n\n# Look at the Defensive Back since they have the most difference between natural and synthetic\ndatadb<-filter(data,PositionGroup==\"DB\")\ndatadb%>%group_by(Surface)%>%summarise(avgspeed=mean(s))->speed\nspeed  #Speed is higher in synthetic\nt.test(datadb[datadb$Surface==\"Natural\",]$s,datadb[datadb$Surface==\"Synthetic\",]$s)\n\ndatadb$unc<-abs(datadb$o-datadb$dir)\ndatadb%>%group_by(Surface)%>%summarise(avgunc=mean(unc))->uncontrol\nuncontrol\nt.test(datadb[datadb$Surface==\"Natural\",]$unc,datadb[datadb$Surface==\"Synthetic\",]$unc)\n\ndatadb$stress<-abs(datadb$o-datadb$dir)*datadb$s # Maybe use this as metric to assess risk of injury?\ndatadb%>%group_by(Surface)%>%summarise(avgstress=mean(stress))->stress\nstress\nt.test(datadb[datadb$Surface==\"Natural\",]$stress,datadb[datadb$Surface==\"Synthetic\",]$stress)\n\nnfl_data%>%group_by(Injured)%>%summarise(avgmstress=mean(Max_Stress))->Max_Stress\nMax_Stress\nt.test(nfl_data[nfl_data$Injured==TRUE,]$Max_Stress,nfl_data[nfl_data$Injured==FALSE,]$Max_Stress)\n\n","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"**Plots**"},{"metadata":{"trusted":true},"cell_type":"code","source":"players<-unique(datadb$PlayerKey)\npar(mai=c(1,0.4,0.4,0.4))\nplot(0,0,ylim=c(0,53.3),xlim=c(0,120),ylab=\"\",xlab=\"\"\n     ,col=\"white\", axes=FALSE,main=\"Defensive Back Movement (Synthetic)\")\npolygon(c(0,0,120,120),c(0,53.3,53.3,0),col=\"#3bc43b\")\npolygon(c(0,0,10,10),c(0,53.3,53.3,0),col=\"#4682B4\")\npolygon(c(110,110,120,120),c(0,53.3,53.3,0),col=\"#4682B4\")\ntext(5,27.5,\"HOME ENDZONE\",srt=90,col=\"yellow\",font=2)\ntext(115,27.5,\"VISITOR ENDZONE\",srt=90,col=\"yellow\",font=2)\nabline(v=seq(0,120,10),lty=2,col=\"white\")\naxis(side=1, labels=TRUE, at=seq(0,120,by=10),font=1,pos=-8)\nfor (i in players){\n  player1<-datadb[datadb$PlayerKey==i,]  #47307 both knee and ankle\n  if (player1$Surface[1]==\"Synthetic\"){\n    lines(player1$x,player1$y,lwd=2)\n    for (j in seq(1,dim(player1)[1],10)){\n      Arrowhead(player1$x[j],player1$y[j],angle=player1$o[j],arr.type=\"triangle\",\n                arr.col=\"white\", lcol=\"black\",arr.length=0.3,xpd=TRUE)}\n    Arrowhead(player1$x[1],player1$y[1],angle=player1$o[1],arr.type=\"triangle\",\n              arr.col=\"orange\", lcol=\"black\",arr.length=0.3)\n    Arrowhead(player1$x[dim(player1)[1]],player1$y[dim(player1)[1]],angle=player1$o[dim(player1)[1]],arr.type=\"triangle\",\n              arr.col=\"red\", lcol=\"black\",arr.length=0.3)\n    legend(90, 10, legend=c(\"Start\", \"Finish\"),\n           col=c(\"orange\",\"red\"), lty=c(1,1), cex=0.8, text.font=1, bg='white')\n  }\n}\n\npar(mai=c(1,0.4,0.4,0.4))\nplot(0,0,ylim=c(0,53.3),xlim=c(0,120),ylab=\"\",xlab=\"\"\n     ,col=\"white\", axes=FALSE, main=\"Defensive Back Movement (Natural)\")\npolygon(c(0,0,120,120),c(0,53.3,53.3,0),col=\"dark green\")\npolygon(c(0,0,10,10),c(0,53.3,53.3,0),col=\"#4682B4\")\npolygon(c(110,110,120,120),c(0,53.3,53.3,0),col=\"#4682B4\")\ntext(5,27.5,\"HOME ENDZONE\",srt=90,col=\"yellow\",font=2)\ntext(115,27.5,\"VISITOR ENDZONE\",srt=90,col=\"yellow\",font=2)\nabline(v=seq(0,120,10),lty=2,col=\"white\")\naxis(side=1, labels=TRUE, at=seq(0,120,by=10),font=1,pos=-8)\nfor (i in players){\n  player1<-datadb[datadb$PlayerKey==i,]  #47307 both knee and ankle\n  if (player1$Surface[1]==\"Natural\"){\n    lines(player1$x,player1$y,lwd=2)\n    for (j in seq(1,dim(player1)[1],10)){\n      Arrowhead(player1$x[j],player1$y[j],angle=player1$o[j],arr.type=\"triangle\",\n                arr.col=\"white\", lcol=\"black\",arr.length=0.3,xpd=TRUE)}\n    Arrowhead(player1$x[1],player1$y[1],angle=player1$o[1],arr.type=\"triangle\",\n              arr.col=\"orange\", lcol=\"black\",arr.length=0.3)\n    Arrowhead(player1$x[dim(player1)[1]],player1$y[dim(player1)[1]],angle=player1$o[dim(player1)[1]],arr.type=\"triangle\",\n              arr.col=\"red\", lcol=\"black\",arr.length=0.3)\n    legend(90, 10, legend=c(\"Start\", \"Finish\"),\n           col=c(\"orange\",\"red\"), lty=c(1,1), cex=0.8, text.font=1, bg='white')\n  }\n}\n\npar(mfrow=c(1,1),bg=\"grey\")\nfor (i in players){\n  color=NULL\n  player1<-datadb[datadb$PlayerKey==i,] \n  if (player1$Surface[1]==\"Synthetic\") color=\"green\" else color=\"dark green\"\n  plot(0,0,ylim=c(min(player1$y),max(player1$y)),xlim=c(min(player1$x),max(player1$x)),ylab=\"\",xlab=\"\"\n       ,col=\"white\", axes=FALSE, main=\"\")\n  lines(player1$x,player1$y,lwd=2,col=color)\n  for (j in seq(1,dim(player1)[1],5)){\n    if (player1$stress[j]>quantile(player1$stress,0.9)){\n    Arrowhead(player1$x[j],player1$y[j],angle=player1$o[j],arr.type=\"triangle\",\n              arr.col=\"blue\", lcol=\"black\",arr.length=0.3,xpd=TRUE)} else {\n                Arrowhead(player1$x[j],player1$y[j],angle=player1$o[j],arr.type=\"triangle\",\n                          arr.col=\"white\", lcol=\"black\",arr.length=0.3,xpd=TRUE)\n              }\n  }\n  Arrowhead(player1$x[1],player1$y[1],angle=player1$o[1],arr.type=\"triangle\",\n            arr.col=\"orange\", lcol=\"black\",arr.length=0.3)\n  Arrowhead(player1$x[dim(player1)[1]],player1$y[dim(player1)[1]],angle=player1$o[dim(player1)[1]],arr.type=\"triangle\",\n            arr.col=\"red\", lcol=\"black\",arr.length=0.3)\n  Arrowhead(player1$x[which.max(player1$stress)],player1$y[which.max(player1$stress)],arr.col=\"purple\",lcol=\"Black\")\n  legend(min(player1$x), min(player1$y)+5, legend=c(\"Start\", \"Finish\", \"High Stress\"),\n         col=c(\"orange\",\"red\", \"blue\"), lty=c(1,1,1), cex=0.8, text.font=1, bg='white')\n}\n\n\n","execution_count":null,"outputs":[]}],"metadata":{"kernelspec":{"display_name":"R","language":"R","name":"ir"},"language_info":{"mimetype":"text/x-r-source","name":"R","pygments_lexer":"r","version":"3.4.2","file_extension":".r","codemirror_mode":"r"}},"nbformat":4,"nbformat_minor":1}