modified_implementation.Rmd

---
title: "modified implementation"
author: "Daniel DeCollo"
date: "2023-04-01"
output: html_document
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```

```{r}
#Clean Environment
rm(list = ls())

#Import Libraries
library(ggplot2)
library(data.table)
library(dplyr)
library(xgboost)
library(ROSE)
library(pROC)
library(caret)
```

## Get data
```{r}
season_2009 <- fread('./season_2009.csv')
season_2010 <- fread('./season_2010.csv')
season_2011 <- fread('./season_2011.csv')
season_2012 <- fread('./season_2012.csv')
season_2013 <- fread('./season_2013.csv')
season_2014 <- fread('./season_2014.csv')
season_2015 <- fread('./season_2015.csv')
season_2016 <- fread('./season_2016.csv')
season_2017 <- fread('./season_2017.csv')
season_2018 <- fread('./season_2018.csv')
season_2019 <- fread('./season_2019.csv')
season_2020 <- fread('./season_2020.csv')
season_2021 <- fread('./season_2021.csv')
```

## Preprocessing - superbowl winners
0 indicates that the team did not win the SuperBowl. For teams that win, the 0 is changed to a 1.

```{r}
#2009
season_2009$super_bowl_winner <- 0
season_2009$super_bowl_winner[season_2009$Teams == "Steelers"] <- 1

#2010
season_2010$super_bowl_winner <- 0
season_2010$super_bowl_winner[season_2010$Teams == "Saints"] <- 1

#2011
season_2011$super_bowl_winner <- 0
season_2011$super_bowl_winner[season_2011$Teams == "Packers"] <- 1

#2012
season_2012$super_bowl_winner <- 0
season_2012$super_bowl_winner[season_2012$Teams == "Giants"] <- 1

#2013
season_2013$super_bowl_winner <- 0
season_2013$super_bowl_winner[season_2013$Teams == "Ravens"] <- 1

#2014
season_2014$super_bowl_winner <- 0
season_2014$super_bowl_winner[season_2014$Teams == "Seahawks"] <- 1

#2015
season_2015$super_bowl_winner <- 0
season_2015$super_bowl_winner[season_2015$Teams == "Patriots"] <- 1

#2016
season_2016$super_bowl_winner <- 0
season_2016$super_bowl_winner[season_2016$Teams == "Broncos"] <- 1

#2017
season_2017$super_bowl_winner <- 0
season_2017$super_bowl_winner[season_2017$Teams == "Patriots"] <- 1

#2018
season_2018$super_bowl_winner <- 0
season_2018$super_bowl_winner[season_2018$Teams == "Eagles"] <- 1

#2019
season_2019$super_bowl_winner <- 0
season_2019$super_bowl_winner[season_2019$Teams == "Patriots"] <- 1

#2020
season_2020$super_bowl_winner <- 0
season_2020$super_bowl_winner[season_2020$Teams == "Chiefs"] <- 1

#2021
season_2021$super_bowl_winner <- 0
season_2021$super_bowl_winner[season_2021$Teams == "Buccaneers"] <- 1
```

## training/ testing data
Training: 2009 - 2014
Testing: 2015 - 2020
Validation: 2021
```{r}
#merge training data
training <- rbind(season_2009, season_2010, season_2011, 
                 season_2012, season_2013, season_2014)

#join 2018-2020 for testing data
testing <- rbind(season_2015, season_2016, season_2017,
                 season_2018, season_2019, season_2020)

#Validation data
validation <- season_2021
```

First few rows of testing data
```{r}
head(testing)
```

## drop unused columns
Remove the team name.
```{r}
training <- training[,-'Teams']

testing <- testing[,-'Teams']
```

## training size
Display the data imbalance for the Superbowl winners. Only one team can win per season so there has to be an imbalance to start.
```{r}
#number of rows that indicate winning teams
table(training$super_bowl_winner == 1)
```

## Percentage of minority observation
Only about 3% of the training data represents a SuperBowl winning team.
```{r}
sum(training$super_bowl_winner)/nrow(training)*100
```

## Oversampling for data imbalance
The original training dataset was 192 row. With ROSE, we are able to add synthetic data to expand it. Our ROSE training dataset is 1000 rows. ROSE also allows us to address the data imbalance. Everytime a row is added to the data, there is a 50% chance that the row will represent a SuperBowl winning team.
```{r}
#desired length of training
n_train <- 1000

#probability of minority class being generated
p_minority <- 0.5 

rose_training <- ROSE(as.factor(super_bowl_winner) ~ ., data  = training, N = n_train, p = p_minority, seed = 412)$data
```

## New training table
Almost 50% of our ROSE training data represents a SuperBowl winning teams.
```{r}
table(rose_training$super_bowl_winner == 1)
```

## train model
We trained two models. The first model was trained using our original training data. It has 192 rows and 3.125% of the data represents a SuperBowl winning team.

The second model was trained with our ROSE training data. It has 1000 rows and 49.4% of the data represents a SuperBowl winning team.

### Backwards Selection - ROSE model
```{r}
int_only_model <- glm(super_bowl_winner ~ 1, 
                      family = binomial,
                      data = rose_training)

full_model <- glm(super_bowl_winner ~  win_percent + total_points +
                    total_rushing_yards + total_passing_yards + total_yards +
                        total_turnovers + def_st_td + first_downs, 
                  data = rose_training, family = binomial())

rose_model <- stats::step(object = full_model, 
            scope = list(lower = int_only_model, upper = full_model),
            data = rose_training,
            direction = "backward")
```


```{r}
original_model <- glm(super_bowl_winner ~ win_percent + total_points + total_passing_yards + 
    total_turnovers + def_st_td, 
                      data = training, family = binomial())
```


## Model Summary
```{r}
summary(original_model)
```

```{r}
summary(rose_model)
```

## test model
Adds the probability for the team to win according to the two models.
```{r}
testing$prediction <- predict(original_model, newdata = testing, type = "response")

#test ROSE model
testing$rose_prediction <- predict(rose_model, newdata = testing, type = "response")
```

This is the probability generated from the first model. Blue dots represent the actual winners. Most of the points are under 25%, including all of the winners.
```{r}
#plot for original model
ggplot(testing, aes(x = reorder(prediction, prediction), y = prediction)) +
  geom_point(aes(colour = super_bowl_winner)) +
  ylim(0, 1) +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5)) +
  theme(legend.position = "none", axis.text.x = element_blank()) + 
  xlab("Probability") +
  ylab("Probability")  + 
  ggtitle("Testing: Original GLM PREDICTION")
```

This is the probability generated from the ROSE model. Blue dots represent the actual winners. The points distributed a little more and 5 out of 6 of the winners are above 50%. 3 out of 6 of the winners are above 75%.
```{r}
#plot for original model
ggplot(testing, aes(x = reorder(rose_prediction, rose_prediction), y = rose_prediction)) +
  geom_point(aes(colour = super_bowl_winner)) +
  ylim(0, 1) +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5)) +
  theme(legend.position = "none", axis.text.x = element_blank()) + 
  xlab("ROSE Probability")  + 
  ylab("ROSE Probability")  + 
  ggtitle("Testing: ROSE GLM PREDICTION")
```

## AUC
Original
```{r}
auc(testing$super_bowl_winner, testing$prediction)
```

ROSE
```{r}
auc(testing$super_bowl_winner, testing$rose_prediction)
```

## Confusion Matrix
```{r}
threshold=0.50
temp <- testing %>% select(super_bowl_winner)
temp$predicted_values <- ifelse(testing$prediction>threshold,1,0)
temp$rose_predicted_values <- ifelse(testing$rose_prediction>threshold,1,0)

original_conf_matrix<-table(temp$predicted_values, temp$super_bowl_winner)
rose_conf_matrix<-table(temp$rose_predicted_values, temp$super_bowl_winner)
```


Original
Does not pick a winning team since everything is bellow 30% probability
```{r}
original_conf_matrix

#sensitivity
#sensitivity(original_conf_matrix)
```


ROSE Matrix
```{r}
rose_conf_matrix

#sensitivity
sensitivity(rose_conf_matrix)
```


## Validation
```{r}
validation$prediction <- predict(original_model, newdata = validation, type = "response")

#test ROSE model
validation$rose_prediction <- predict(rose_model, newdata = validation, type = "response")
```

With original model, if a team tied, then it could not win the superbowl
```{r}
ggplot(validation, aes(x = reorder(Teams, prediction), y = prediction)) +
  geom_point(aes(colour = super_bowl_winner, size = 1)) +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5)) +
  theme(legend.position = "none") + 
  ylim(0, 1) +
  xlab("NFL Teams") + 
  ylab("Predicted Winner") + 
  ggtitle("2021 Super Bowl Winner Prediction")
```

```{r}
ggplot(validation, aes(x = reorder(Teams, rose_prediction), y = rose_prediction)) +
  geom_point(aes(colour = super_bowl_winner, size = 1)) +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5)) +
  theme(legend.position = "none") + 
  ylim(0, 1) +
  xlab("NFL Teams") + 
  ylab("Predicted Winner") + 
  ggtitle("2021 Super Bowl Winner Prediction")
```