Uncertainty Part 2b

class: center, middle, inverse, title-slide

.title[
# Uncertainty Part 2b
]
.subtitle[
## Sports Analytic Mania: Bootstrapping!
]
.author[
### Prof. Weldzius
]
.institute[
### Villanova University
]

---

# Agenda

1. Uncertainty

2. More NBA data

3. Bootstrap Sampling!

---

# Sports Analytics Continued

- Load the `game_summary.Rds` data

``` r
require(tidyverse)
gms <- read_rds('../data/game_summary.Rds')
gms
```

```
## # A tibble: 7,380 × 16
##    idGame yearSeason dateGame   idTeam nameTeam locationGame
##     <dbl>      <int> <date>      <dbl> <chr>    <chr>       
##  1 2.16e7       2017 2016-10-25 1.61e9 Clevela… H           
##  2 2.16e7       2017 2016-10-25 1.61e9 New Yor… A           
##  3 2.16e7       2017 2016-10-25 1.61e9 Portlan… H           
##  4 2.16e7       2017 2016-10-25 1.61e9 Utah Ja… A           
##  5 2.16e7       2017 2016-10-25 1.61e9 Golden … H           
##  6 2.16e7       2017 2016-10-25 1.61e9 San Ant… A           
##  7 2.16e7       2017 2016-10-26 1.61e9 Miami H… A           
##  8 2.16e7       2017 2016-10-26 1.61e9 Orlando… H           
##  9 2.16e7       2017 2016-10-26 1.61e9 Dallas … A           
## 10 2.16e7       2017 2016-10-26 1.61e9 Indiana… H           
## # ℹ 7,370 more rows
## # ℹ 10 more variables: tov <dbl>, pts <dbl>, treb <dbl>,
## #   oreb <dbl>, pctFG <dbl>, pctFT <dbl>, teamrest <dbl>,
## #   second_game <lgl>, isWin <lgl>, ft_80 <dbl>
```

---

# Remember the .blue[Science]

- What predicts winning?

- Points? (more is better)
  - Turnovers? (less is better)
  - Rebounds? (more is better)
  
--

- On average, winning teams have ~1 fewer turnover than losing teams

- FSNoR: is this *always* the case?

- Use **bootstrap sampling** to see!

---

# Looping

``` r
set.seed(123)
bs_tov <- NULL
for(i in 1:1000) {
  bs_tov <- gms %>%
    sample_n(size = 100,replace = T) %>%
    group_by(isWin) %>%
    summarise(avgTO = mean(tov)) %>%
    bind_rows(bs_tov)
}
bs_tov %>% head()
```

```
## # A tibble: 6 × 2
##   isWin avgTO
##   <lgl> <dbl>
## 1 FALSE  13.6
## 2 TRUE   13.3
## 3 FALSE  13.9
## 4 TRUE   13.0
## 5 FALSE  14.1
## 6 TRUE   13.0
```

---

# Bootstrapped Estimates vs Data

``` r
bs_tov %>%
  group_by(isWin) %>%
  summarise(bs_est = mean(avgTO))
```

```
## # A tibble: 2 × 2
##   isWin bs_est
##   <lgl>  <dbl>
## 1 FALSE   13.9
## 2 TRUE    13.1
```

``` r
gms %>%
  group_by(isWin) %>%
  summarise(data_est = mean(tov))
```

```
## # A tibble: 2 × 2
##   isWin data_est
##   <lgl>    <dbl>
## 1 FALSE     13.9
## 2 TRUE      13.1
```

---

# Bootstrapped Estimates vs Data

- They're identical!

- In .blue[theory], bootstrapped samples converge on true values
  
--

- ...where "true" is the full data
  
--

- So then why bother with bootstrapping?

- **Uncertainty!**

---

# Plot Distributions of Bootstraps

``` r
bs_tov %>%
  ggplot(aes(x = avgTO,fill = isWin)) + 
  geom_density(alpha = .3)
```

---

# Generalizability

- What if we only used one season?

- Do we think our conclusions would "generalize" (i.e., apply to) other seasons?

- For example, is the turnover-win relationship the same in the 2017 season as the 2018 season?
  
--

- What about the 2019 season?
  
--

- Why or why not?
  
--

- Demonstrate using the 2017 data

---

# Generalizability

- Bootstrap + `group_by`

``` r
bsRes <- NULL

for(i in 1:500) {  # Only 500 simulations this time
  bsRes <- gms %>%
    group_by(yearSeason) %>% #<< Group by the season
    sample_n(size = 100,replace = T) %>% #<< Get 100 observations per season
    group_by(yearSeason,isWin) %>% #<< Then calculate mean tov by season AND win
    summarise(avgTO = mean(tov,na.rm=T),.groups = 'drop') %>%
    ungroup() %>%
    mutate(bsInd = i) %>%
    bind_rows(bsRes)
  
}
```

---

# Plotting the results

``` r
bsRes %>%
  ggplot(aes(x = avgTO)) + 
  geom_density(alpha = .3)
```

- Is this answering our .blue[question]?

---

# Plotting the results

``` r
bsRes %>%
  ggplot(aes(x = avgTO,fill = isWin)) + 
  geom_density(alpha = .3)
```

- Is this answering our .blue[question]?

---

# Plotting the results

``` r
bsRes %>%
  ggplot(aes(x = avgTO,fill = isWin)) + 
  geom_density(alpha = .3) + 
* facet_grid(yearSeason~.)
```

---

# Plotting the results

``` r
p  <- bsRes %>%
  ggplot(aes(x = avgTO,fill = isWin)) + 
  geom_density(alpha = .3) + 
* geom_vline(data = bsRes %>%
*              group_by(yearSeason,isWin) %>%
*              summarise(avgTO = mean(avgTO,na.rm=T)),
*            aes(xintercept = avgTO,color = isWin),linetype = 'dashed') +
* geom_text(data = bsRes %>%
*              group_by(yearSeason,isWin) %>%
*              summarise(avgTO = mean(avgTO,na.rm=T)),
*            aes(x = avgTO,y = Inf,label = round(avgTO,1)),hjust = 1.1,vjust = 1.1,size = 3,angle = 90) +
  facet_grid(yearSeason~.) 
```

---

# Plotting the results

``` r
p
```

---

# Plotting the results

``` r
p  <- bsRes %>%
  ggplot(aes(x = avgTO,fill = isWin)) + 
  geom_density(alpha = .3) + 
  geom_vline(data = bsRes %>% 
               group_by(yearSeason,isWin) %>%
               summarise(avgTO = mean(avgTO,na.rm=T)),
             aes(xintercept = avgTO,color = isWin),linetype = 'dashed') + 
  geom_text(data = bsRes %>%
               group_by(yearSeason,isWin) %>%
               summarise(avgTO = mean(avgTO,na.rm=T)),
*            aes(x = avgTO,y = Inf,label = round(avgTO,1)),hjust = 1.1,vjust = 1.1,size = 3,angle = 90) +
  facet_grid(yearSeason~.) 
```

- *Pause*: try changing `hjust` and `vjust` to see how it moves the text on the plot

---

# Summarizing further

- We are *actually* interested in whether winning teams turnover the ball less

- .blue[Science]: never forget your theory / hypothesis!
  
--

- So let's actually calculate this!

- The `spread` command to create two columns

``` r
bsRes %>%
  spread(isWin,avgTO,sep = '_') %>%
  mutate(TO_diff = isWin_FALSE - isWin_TRUE)
```

```
## # A tibble: 1,500 × 5
##    yearSeason bsInd isWin_FALSE isWin_TRUE TO_diff
##         <int> <int>       <dbl>      <dbl>   <dbl>
##  1       2017     1        14.3       13.1  1.16  
##  2       2017     2        14.1       12.5  1.60  
##  3       2017     3        13.6       13.9 -0.285 
##  4       2017     4        13.6       12.3  1.34  
##  5       2017     5        14.1       13.4  0.739 
##  6       2017     6        14.3       12.9  1.47  
##  7       2017     7        13.4       13.4 -0.0161
##  8       2017     8        13.7       13    0.696 
##  9       2017     9        13.9       12.5  1.41  
## 10       2017    10        14.2       13.1  1.12  
## # ℹ 1,490 more rows
```

---

# Generalizability

``` r
bsRes %>%
  spread(isWin,avgTO,sep = '_') %>% 
  mutate(TO_diff = isWin_FALSE - isWin_TRUE) %>%
  ggplot(aes(x = TO_diff,fill = factor(yearSeason))) + 
  geom_density(alpha = .3)
```

---

# Comparing across seasons

``` r
p <- bsRes %>%
  spread(isWin,avgTO,sep = '_') %>%
  mutate(TO_diff = isWin_FALSE - isWin_TRUE) %>%
  ggplot(aes(x = TO_diff,group = yearSeason)) + 
  geom_density(alpha = .3) + 
  geom_vline(xintercept = 0) + 
  geom_text(data = bsRes %>%
             spread(isWin,avgTO,sep = '_') %>%
             mutate(TO_diff = isWin_FALSE - isWin_TRUE) %>%
             group_by(yearSeason) %>%
             summarise(conf = mean(TO_diff > 0),
                       TO_diff = mean(TO_diff),
                       y = .25),
            aes(x = TO_diff,y = y,label = paste0(round(conf*100,1),'%'))) + 
  facet_grid(yearSeason ~.)
```

---

# Comparing across seasons

``` r
p
```

---

# Visualization is **DEEP**

``` r
toplot <- bsRes %>%
  spread(isWin,avgTO,sep = '_') %>%
  mutate(TO_diff = isWin_FALSE - isWin_TRUE)

tmp <- density(toplot$TO_diff)
p <- data.frame(x = tmp$x,y = tmp$y, area = tmp$x >= 0) %>%
  ggplot(aes(x = x,ymin = 0,ymax = y,fill = area)) + 
  geom_ribbon(alpha = .6) + 
  geom_vline(xintercept = 0,linetype = 'dashed',size = 1.1) + 
  annotate(geom = 'text',x = mean(toplot$TO_diff),y = .25,
*          label = paste0("Losing team had\nmore turnovers in\n",round(mean(toplot$TO_diff > 0),3)*100,"% of\nBootstraps"),
           hjust = .5) + 
  labs(title = 'Difference in Turnovers by Game Outcome',
       subtitle = '1,000 Bootstrapped Estimates from 2016-2019 Seasons',
       x = 'Losing Team Turnovers minus Winning Team Turnovers',
       y = 'Density of Simulated Games') + 
  scale_fill_manual(name = 'Who Had More Turnovers',
                    values = c('grey60','slateblue'),labels = c('Winning Team','Losing Team')) + 
  theme(panel.background = element_blank(),
        legend.position = 'bottom')
```

---

# Visualization is **DEEP**

- **Side-bar**: If asked in an interview to reproduce this plot, could you? (*Actual* question asked for a research position at UPenn.)