Classification

class: center, middle, inverse, title-slide

.title[
# Classification
]
.subtitle[
## Part 1b
]
.author[
### Prof. Ryan Weldzius
]
.institute[
### Villanova University
]

---

# Agenda

1. Classification Continued

2. Fortnite gaming

``` r
require(tidyverse)
require(scales)
fn <- read_rds('../Data/fn_cleaned_final.rds') %>%
  mutate(hits_decile = ntile(hits,n=10)) %>% # Bin hits by decile (10%)
  group_by(hits_decile,mental_state) %>% # Calculate average winning by mental state and accuracy
  mutate(prob_win = mean(won)) %>% # use mutate() instead of summarise() to avoid collapsing the data
  mutate(pred_win = ifelse(prob_win > .5,1,0)) %>% # If the probability is greater than 50-50, predict a win
  ungroup()
```

---

# Recap of Last time

- What is "accuracy"?

- Proportion "correct" predictions
  
--

- For a binary outcome, "accuracy" has two dimensions

- Proportion of correct `1`s: **Sensitivity**
  
  - Proportion of correct `0`s: **Specificity**
  
---

# Accuracy

``` r
(sumTab <- fn %>%
  group_by(won) %>%
  mutate(total_games = n()) %>%
  group_by(won,pred_win,total_games) %>%
  summarise(nGames=n(),.groups = 'drop') %>%
  mutate(prop = nGames / total_games))
```

```
## # A tibble: 4 × 5
##     won pred_win total_games nGames   prop
##   <dbl>    <dbl>       <int>  <int>  <dbl>
## 1     0        0         666    625 0.938 
## 2     0        1         666     41 0.0616
## 3     1        0         291    241 0.828 
## 4     1        1         291     50 0.172
```

- Overall accuracy: (625+50) / (666+291) = 71%

- But we are doing **great** at predicting losses (94%)...

- ...and **terribly** at predicting wins (17%)

---

# Regression

``` r
fn %>%
  ggplot(aes(x = damage_to_players,y = won)) + 
  geom_point() + 
  geom_smooth(method = 'lm')
```

---

# Regression

- Binary outcome variable!

- A linear regression is not the best solution
  
--

- Predictions can exceed support of `$Y$`

- But it can still work! **linear probability model**

``` r
mLM <- lm(won ~ hits + accuracy + mental_state,fn)
```

---

# Linear Regression

``` r
require(broom) # broom package makes it easy to read regression output
tidy(mLM) %>% # This would be the same as summary(mLM)
  mutate_at(vars(-term),function(x) round(x,5))
```

```
## # A tibble: 4 × 5
##   term              estimate std.error statistic p.value
##   <chr>                <dbl>     <dbl>     <dbl>   <dbl>
## 1 (Intercept)        0.219     0.0336       6.52       0
## 2 hits               0.00646   0.00065      9.91       0
## 3 accuracy          -0.725     0.108       -6.72       0
## 4 mental_statesober  0.155     0.0281       5.53       0
```

---

# Evaluating Predictions

``` r
mLM <- lm(won ~ hits + accuracy + mental_state + damage_taken + head_shots + gameIdSession,fn)
fn %>%
  mutate(preds = predict(mLM)) %>%
  mutate(predBinary = ifelse(preds > .5,1,0)) %>%
  select(won,predBinary,preds)
```

```
## # A tibble: 957 × 3
##      won predBinary  preds
##    <dbl>      <dbl>  <dbl>
##  1     0          0 0.320 
##  2     0          0 0.239 
##  3     0          0 0.193 
##  4     0          0 0.285 
##  5     0          0 0.148 
##  6     0          0 0.175 
##  7     0          0 0.258 
##  8     0          0 0.115 
##  9     0          0 0.239 
## 10     1          0 0.0982
## # ℹ 947 more rows
```

---

# Evaluating Predictions

``` r
(sumTab <- fn %>%
  mutate(pred_win = ifelse(predict(mLM) > .5,1,0)) %>%
  group_by(won) %>%
  mutate(total_games = n()) %>%
  group_by(won,pred_win,total_games) %>%
  summarise(nGames=n(),.groups = 'drop') %>%
  mutate(prop = percent(nGames / total_games)) %>%
  ungroup() %>%
  mutate(accuracy = percent(sum((won == pred_win)*nGames) / sum(nGames))))
```

```
## # A tibble: 4 × 6
##     won pred_win total_games nGames prop  accuracy
##   <dbl>    <dbl>       <int>  <int> <chr> <chr>   
## 1     0        0         666    615 92%   71%     
## 2     0        1         666     51 8%    71%     
## 3     1        0         291    226 78%   71%     
## 4     1        1         291     65 22%   71%
```

---

# Evaluating Predictions

- Overall accuracy is just the number of correct predictions (either `0` or `1`) out of all possible

- Is 71% good?

- What would the dumbest guess be? Never win! 70%

- Might also want to care about just `1`s

- **Sensitivity**: Predicted wins / actual wins = 22%
  
--

- Also might care about just `0`s

- **Specificity**: Predicted losses / actual losses = 92%
  
---

# Thresholds

- Shifting the threshold for `0` or `1` prediction can matter

``` r
fn %>%
  mutate(pred_win = ifelse(predict(mLM) > .4,1,0)) %>%
  group_by(won) %>%
  mutate(total_games = n()) %>%
  group_by(won,pred_win,total_games) %>%
  summarise(nGames=n(),.groups = 'drop') %>%
  mutate(prop = percent(nGames / total_games)) %>%
  ungroup() %>%
  mutate(accuracy = percent(sum((won == pred_win)*nGames) / sum(nGames)))
```

```
## # A tibble: 4 × 6
##     won pred_win total_games nGames prop  accuracy
##   <dbl>    <dbl>       <int>  <int> <chr> <chr>   
## 1     0        0         666    542 81.4% 72%     
## 2     0        1         666    124 18.6% 72%     
## 3     1        0         291    144 49.5% 72%     
## 4     1        1         291    147 50.5% 72%
```

---

# Thresholds

- Shifting the threshold for `0` or `1` prediction can matter

``` r
fn %>%
  mutate(pred_win = ifelse(predict(mLM) > .7,1,0)) %>%
  group_by(won) %>%
  mutate(total_games = n()) %>%
  group_by(won,pred_win,total_games) %>%
  summarise(nGames=n(),.groups = 'drop') %>%
  mutate(prop = percent(nGames / total_games)) %>%
  ungroup() %>%
  mutate(accuracy = percent(sum((won == pred_win)*nGames) / sum(nGames)))
```

```
## # A tibble: 4 × 6
##     won pred_win total_games nGames prop  accuracy
##   <dbl>    <dbl>       <int>  <int> <chr> <chr>   
## 1     0        0         666    663 99.5% 70%     
## 2     0        1         666      3 0.5%  70%     
## 3     1        0         291    280 96.2% 70%     
## 4     1        1         291     11 3.8%  70%
```

- Restricting to above 70% means we don't think anyone wins!

---

# Thresholds

- We could keep trying different values until we hit on one that maximizes our accuracy

- But this is inefficient! Let's loop it instead!

``` r
toplot <- NULL
for(thresh in seq(0,1,by = .025)) {
  toplot <- fn %>%
  mutate(pred_win = ifelse(predict(mLM) > thresh,1,0)) %>%
  group_by(won) %>%
  mutate(total_games = n()) %>%
  group_by(won,pred_win,total_games) %>%
  summarise(nGames=n(),.groups = 'drop') %>%
  mutate(prop = nGames / total_games) %>%
  ungroup() %>%
  mutate(accuracy = sum((won == pred_win)*nGames) / sum(nGames)) %>%
  mutate(threshold = thresh) %>%
    bind_rows(toplot)
}
```

---

# Thresholds

- We might only care about accuracy by itself (although this is a bit naive)

.small[

``` r
toplot %>%
  select(accuracy,threshold) %>%
  distinct() %>%
  ggplot(aes(x = threshold,y = accuracy)) + 
  geom_line()
```

<img src="12b_ClassificationPart1_files/figure-html/unnamed-chunk-13-1.png" style="display: block; margin: auto;" />
]

---

# Thresholds

.small[

``` r
toplot %>%
  mutate(metric = ifelse(won == 1 & pred_win == 1,'Sensitivity',
                         ifelse(won == 0 & pred_win == 0,'Specificity',NA))) %>%
  drop_na(metric) %>%
  ggplot(aes(x = threshold,y = prop,color = metric)) + 
  geom_line()
```

<img src="12b_ClassificationPart1_files/figure-html/unnamed-chunk-14-1.png" style="display: block; margin: auto;" />
]

---

# ROC Curve

- Receiver-Operator Characteristic (ROC) Curve

- Commonly used to evaluate classification methods

- X-axis: 1-specificity

- Y-axis: sensitivity

``` r
p <- toplot %>%
  mutate(metric = ifelse(won == 1 & pred_win == 1,'Sensitivity',
                         ifelse(won == 0 & pred_win == 0,'Specificity',NA))) %>%
  drop_na(metric) %>%
  select(prop,metric,threshold) %>%
  spread(metric,prop) %>%
  arrange(desc(Specificity),Sensitivity) %>%
  ggplot(aes(x = 1-Specificity,y = Sensitivity)) + 
  geom_line() + 
  xlim(c(0,1)) + ylim(c(0,1)) + 
  geom_abline(slope = 1,intercept = 0,linetype = 'dotted') + 
  ggridges::theme_ridges()
```

---

# ROC Curve

``` r
p
```

- Better models have high levels of sensitivity **and** specificity at every threshold

---

# AUC Measure

- Area Under the Curve (AUC)

- A single number summarizing classification performance
  
--

``` r
require(tidymodels)
roc_auc(data = fn %>%
  mutate(pred_win = predict(mLM),
         truth = factor(won,levels = c('1','0'))) %>%
  select(truth,pred_win),truth,pred_win)
```

```
## # A tibble: 1 × 3
##   .metric .estimator .estimate
##   <chr>   <chr>          <dbl>
## 1 roc_auc binary         0.736
```

---

# AUC

- What is a "good" AUC?

- We know it is bounded between 0 (i.e., it predicts everything **perfectly wrong**) and 1 (i.e., it predicts everything **perfectly correct**)
  
  - But typically we don't see AUC values less than 0.5 (why is this?)
  
--

- AUC can be interpreted like numeric grades at Villanova (and for this class)

- 0.95+ is amazing
  
  - 0.9 - 0.95 is very good
  
  - 0.8-range is B-tier
  
  - 0.7-range is C-tier
  
  - 0.6-range is really bad
  
  - AUC values less than 0.6 are failing

---

# Party time!

- Adding more variables / trying different combinations

- **Workflow**

1. Train models
  
  2. Predict models
  
  3. Evaluate models
  
---

# Train models

``` r
m1 <- lm(won ~ hits,fn)
m2 <- lm(won ~ hits + head_shots,fn)
m3 <- lm(won ~ hits + accuracy + head_shots,fn)
m4 <- lm(won ~ hits + accuracy + head_shots + mental_state,fn)
m5 <- lm(won ~ hits + accuracy + head_shots + mental_state + distance_traveled,fn)
m6 <- lm(won ~ hits + accuracy + mental_state + head_shots + distance_traveled + gameIdSession,fn)
```

---

# Predict models

``` r
toEval <- fn %>%
  mutate(m1Preds = predict(m1),
         m2Preds = predict(m2),
         m3Preds = predict(m3),
         m4Preds = predict(m4),
         m5Preds = predict(m5),
         m6Preds = predict(m6),
         truth = factor(won,levels = c('1','0')))
```

---

# Evaluate models

``` r
rocRes <- NULL
for(model in 1:6) {
  rocRes <- roc_auc(toEval,truth,paste0('m',model,'Preds')) %>%
    mutate(model = paste0('Model ',model)) %>%
    bind_rows(rocRes)
}
```

---

# Evaluate models

``` r
rocRes %>%
  ggplot(aes(x = .estimate,y = reorder(model,.estimate))) + 
  geom_bar(stat = 'identity') + 
  ggridges::theme_ridges() + labs(x = 'AUC',y = 'Regression Model')
```

---

# OVERFITTING

- Cross validation to the rescue!

.tiny[

``` r
set.seed(123)
cvRes <- NULL
for(i in 1:100) {
  # Cross validation prep
  inds <- sample(1:nrow(fn),size = round(nrow(fn)*.8),replace = F)
  train <- fn %>% slice(inds)
  test <- fn %>% slice(-inds)

# Training models
  m1 <- lm(won ~ hits,train)
  m2 <- lm(won ~ hits + head_shots,train)
  m3 <- lm(won ~ hits + accuracy + head_shots,train)
  m4 <- lm(won ~ hits + accuracy + head_shots + mental_state,train)
  m5 <- lm(won ~ hits + accuracy + head_shots + mental_state + distance_traveled,train)
  m6 <- lm(won ~ hits + accuracy + mental_state + head_shots + distance_traveled + gameIdSession,train)

# Predicting models
  toEval <- test %>%
    mutate(m1Preds = predict(m1,newdata = test),
           m2Preds = predict(m2,newdata = test),
           m3Preds = predict(m3,newdata = test),
           m4Preds = predict(m4,newdata = test),
           m5Preds = predict(m5,newdata = test),
           m6Preds = predict(m6,newdata = test),
           truth = factor(won,levels = c('1','0')))

# Evaluating models
  rocResBS <- NULL
  for(model in 1:6) {
    rocResBS <- roc_auc(toEval,truth,paste0('m',model,'Preds')) %>%
      mutate(model = as.character(get(paste0('m',model))$call$formula)[3]) %>%
      bind_rows(rocResBS)
  }
  cvRes <- rocResBS %>%
    mutate(bsInd = i) %>%
    bind_rows(cvRes)
}
```
]
---

# Cross Validation AUC

``` r
cvRes %>%
  ggplot(aes(x = .estimate,y = factor(reorder(model,.estimate)))) + 
  geom_boxplot() + labs(x = 'Distribution of AUC',y = 'Specification')
```

---

# Conclusion

- Classification is just a type of prediction

- We used linear regression
  
--

- But there are **much** fancier algorithms out there
  
--

- Next class:

- A *slightly* fancier algorithm: logistic regression
  
  - How to use the models to achieve the team's goals