---
title:
output:
  revealjs::revealjs_presentation:
    theme: white
    css: white-edits.css
    highlight: tango
    transition: slide
    self_contained: false
    reveal_plugins: ["chalkboard","search"]
    transitionSpead: fast
    mathjax: "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.1/MathJax.js?config=TeX-AMS_SVG"
    reveal_options:
      minScale: 1.0
      maxScale: 1.0
      width: 1536
      height: 864
      slideNumber: true
      controlsTutorial: true
      chalkboard:
        theme: whiteboard
        readOnly: false
---

## ACCT 420: Project Example {data-background-video="../Backgrounds/title.mp4" data-background-video-loop=true class="header no-toc-progress present-only" data-state="no-toc-progress"}

<!-- "reveal_plugins:..." and "chalkboard:" are handled by prep38.py -->
```{r helpers, echo=FALSE, warning=FALSE, message=F}
library(knitr)
library(kableExtra)
html_df <- function(text, cols=NULL, col1=FALSE, full=F) {
  if(!length(cols)) {
    cols=colnames(text)
  }
  if(!col1) {
    kable(text,"html", col.names = cols, align = c("l",rep('c',length(cols)-1))) %>%
      kable_styling(bootstrap_options = c("striped","hover"), full_width=full)
  } else {
    kable(text,"html", col.names = cols, align = c("l",rep('c',length(cols)-1))) %>%
      kable_styling(bootstrap_options = c("striped","hover"), full_width=full) %>%
      column_spec(1,bold=T)
  }
}
```

<h3 class="date"><br>Project Example</h3>
<h2 class="author"><br>Dr. Richard M. Crowley<br>rcrowley@smu.edu.sg<br><a href="http://rmc.link/">http://rmc.link/</a></h2>

## ACCT 420: Project Example {data-background="../Backgrounds/title.jpg" class="header no-toc-progress present-not" data-state="no-toc-progress"}

<h3 class="date"><br>Project Example</h3>
<h2 class="author"><br>Dr. Richard M. Crowley<br>rcrowley@smu.edu.sg<br><a href="http://rmc.link/">http://rmc.link/</a></h2>


<!-- Load in primary data set -->
```{r, include=FALSE}
library(tidyverse)
weekly <- read.csv("../../Data/WMT_train.csv")
weekly.test <- read.csv("../../Data/WMT_test.csv")
weekly.features <- read.csv("../../Data/WMT_features.csv")
weekly.stores <- read.csv("../../Data/WMT_stores.csv")
```

# Weekly revenue prediction at Walmart {data-background="../Backgrounds/section.jpg" class="header"}

## The question {data-background="../Backgrounds/case.jpg" class="default"}

> How can we predict weekly departmental revenue for Walmart, leveraging our knowledge of Walmart, its business, and some limited historical information?

- Predict weekly for 115,064 (Store, Department, Week) tuples
    - From 2012-11-02 to 2013-07-26
- Using [incomplete] weekly revenue data from 2010-02-015 to 2012-10-26
    - By department (some weeks missing for some departments)

## More specifically... {data-background="../Backgrounds/case.jpg" class="default"}

- Consider time dimensions
    - What matters:
        - Time of the year?
        - Holidays?
        - Do different stores or departments behave differently?
- Wrinkles:
    - Walmart won't give us testing data
        - But they'll tell us how well the algorithm performs
    - We can't use past week sales for prediction because we won't have it for most of the prediction...

## The data {data-background="../Backgrounds/case.jpg" class="default"}

- Revenue by week for each department of each of 45 stores
    - Department is just a number between 1 and 99
        - We don't know what these numbers mean
    - Date of that week
    - If the week is considered a holiday for sales purposes
        - Super Bowl, Labor Day, Black Friday, Christmas
- Store data:
    - Which store the data is for, 1 to 45
    - Store type (A, B, or C)
        - We don't know what these letters mean
    - Store size
- Other data, by week and location:
    - Temperature, gas price, sales (by department), CPI, Unemployment rate, Holidays

## Walmart's evaluation metric {data-background="../Backgrounds/case.jpg" class="default"}

- Walmart uses MAE (mean absolute error), but with a twist:
    - They care more about holidays, so any error on holidays has **5 times** the penalty
    - They call this WMAE, for *weighted* mean absolute error

$$
WMAE = \frac{1}{\sum w_i} \sum_{i=1}^{n} w_i \left|y_i-\hat{y}_i\right|
$$

- $n$ is the number of test data points
- $\hat{y}_i$ is your prediction
- $y_i$ is the actual sales
- $w_i$ is 5 on holidays and 1 otherwise

```{r}
wmae <- function(actual, predicted, holidays) {
  ids <- !is.na(actual) & !is.na(predicted) & !is.na(holidays)
          sum(abs(actual[ids]-predicted[ids])*(holidays[ids]*4+1)) / (length(actual[ids]) + 4*sum(holidays[ids]))
}
```

## Before we get started... {data-background="../Backgrounds/coding.jpg" class="default"}

- The data isn't very clean:
    - Markdowns are given by 5 separate variables instead of 1
    - Date is text format instead of a date
    - CPI and unemployment data are missing in around a third of the testing data
    - There are some (week, store, department) groups missing from our training data!

> We'll have to fix these

## Also... {data-background="../Backgrounds/coding.jpg" class="default"}

- Some features to add:
    - Year
    - Week
    - A unique ID for tracking (week, firm, department) tuples
    - The ID Walmart requests we use for submissions
    - Average sales by (store, department)
    - Average sales by (week, store, department)

## Load data and packages {data-background="../Backgrounds/coding.jpg" class="default"}

<!-- Load in primary data set -->
```{r, message=F}
library(tidyverse)  # we'll extensively use dplyr here
library(lubridate)  # Great for simple date functions
library(broom)
weekly <- read.csv("../../Data/WMT_train.csv", stringsAsFactors=FALSE)
weekly.test <- read.csv("../../Data/WMT_test.csv", stringsAsFactors=FALSE)
weekly.features <- read.csv("../../Data/WMT_features.csv", stringsAsFactors=FALSE)
weekly.stores <- read.csv("../../Data/WMT_stores.csv", stringsAsFactors=FALSE)
```

- `weekly` is our training data
- `weekly.test` is our testing data -- no `Weekly_Sales` column
- `weekly.features` is general information about (week, store) pairs
    - Temperature, pricing, etc.
- `weekly.stores` is general information about each store

## Cleaning {data-background="../Backgrounds/coding.jpg" class="default"}

```{r, message=F}
preprocess_data <- function(df) {
  # Merge the data together (Pulled from outside of function -- "scoping")
  df <- inner_join(df, weekly.stores)
  df <- inner_join(df, weekly.features[,1:11])
  
  # Compress the weird markdown information to 1 variable
  df$markdown <- 0
  df[!is.na(df$MarkDown1),]$markdown <- df[!is.na(df$MarkDown1),]$MarkDown1
  df[!is.na(df$MarkDown2),]$markdown <- df[!is.na(df$MarkDown2),]$MarkDown2
  df[!is.na(df$MarkDown3),]$markdown <- df[!is.na(df$MarkDown3),]$MarkDown3
  df[!is.na(df$MarkDown4),]$markdown <- df[!is.na(df$MarkDown4),]$MarkDown4
  df[!is.na(df$MarkDown5),]$markdown <- df[!is.na(df$MarkDown5),]$MarkDown5
  
  # Fix dates and add useful time variables
  df$date <- as.Date(df$Date)
  df$week <- week(df$date)
  df$year <- year(df$date)
  
  df
}
```
```{r, message=F}
df <- preprocess_data(weekly)
df_test <- preprocess_data(weekly.test)
```

> Merge data, fix `markdown`, build time data

## What this looks like {data-background="../Backgrounds/coding.jpg" class="default"}

```{r}
df[91:94,] %>%
  select(Store, date, markdown, MarkDown3, MarkDown4, MarkDown5) %>%
  html_df()
```

```{r}
df[1:2,] %>% select(date, week, year) %>% html_df()
```


## Cleaning: Missing CPI and Unemployment {data-background="../Backgrounds/coding.jpg" class="default"}

```{r}
# Fill in missing CPI and Unemployment data
df_test <- df_test %>%
  group_by(Store, year) %>%
  mutate(CPI=ifelse(is.na(CPI), mean(CPI,na.rm=T), CPI),
         Unemployment=ifelse(is.na(Unemployment),
                             mean(Unemployment,na.rm=T),
                             Unemployment)) %>%
  ungroup()
```

<img src="../Figures/ifelse.png">

> Apply the (year, Store)'s CPI and Unemployment to missing data

## Cleaning: Adding IDs {data-background="../Backgrounds/coding.jpg" class="default"}

- Build a unique ID
    - Since Store, week, and department are all 2 digits, make a 6 digit number with 2 digits for each
        - `sswwdd`
- Build Walmart's requested ID for submissions
    - `ss_dd_YYYY-MM-DD`

```{r, message=F}
# Unique IDs in the data
df$id <- df$Store *10000 + df$week * 100 + df$Dept
df_test$id <- df_test$Store *10000 + df_test$week * 100 + df_test$Dept

# Unique ID and factor building
#swd <- c(df$id, df_test$id)  # Pool all IDs
#swd <- unique(swd)  # Only keep unique elements
#swd <- data.frame(swd=swd)  # Make a data frame
#swd$swd <- factor(swd$id)  # Extract factors for using later

# Add unique factors to data -- ensures same factors for both data sets
#df <- left_join(df,swd)
#df_test <- left_join(df_test,swd)
```

```{r}
df_test$Id <- paste0(df_test$Store,'_',df_test$Dept,"_",df_test$date)
```

## What the IDs look like {data-background="../Backgrounds/coding.jpg" class="default"}

```{r}
html_df(df_test[c(20000,40000,60000),c("Store","week","Dept","id","Id")])
```

## Add in (store, department) average sales {data-background="../Backgrounds/coding.jpg" class="default"}

```{r}
# Calculate average by store-dept and distribute to df_test
df <- df %>%
  group_by(Store, Dept) %>% 
  mutate(store_avg=mean(Weekly_Sales, rm.na=T)) %>%
  ungroup()
df_sa <- df %>%
  group_by(Store, Dept) %>%
  slice(1) %>%
  select(Store, Dept, store_avg) %>%
  ungroup()
df_test <- left_join(df_test, df_sa)
# 36 observations have messed up department codes -- ignore (set to 0)
df_test[is.na(df_test$store_avg),]$store_avg  <- 0

# Calculate multipliers based on store_avg (and removing NaN and Inf)
df$Weekly_mult <- df$Weekly_Sales / df$store_avg
df[!is.finite(df$Weekly_mult),]$Weekly_mult <- NA
```

## Add in (week, store, dept) average sales {data-background="../Backgrounds/coding.jpg" class="default"}

```{r}
# Calculate mean by week-store-dept and distribute to df_test
df <- df %>%
  group_by(Store, Dept, week) %>%
  mutate(naive_mean=mean(Weekly_Sales, rm.na=T)) %>%
  ungroup()
df_wm <- df %>%
  group_by(Store, Dept, week) %>%
  slice(1) %>%
  ungroup() %>%
  select(Store, Dept, week, naive_mean)
df_test <- df_test %>% arrange(Store, Dept, week)
df_test <- left_join(df_test, df_wm)
```

## ISSUE: New (week, store, dept) groups {data-background="../Backgrounds/coding.jpg" class="default"}

- This is in our testing data!
    - So we'll need to predict out groups we haven't observed at all

```{r}
table(is.na(df_test$naive_mean))
```

- Fix: Fill with 1 or 2 lags where possible using `ifelse()` and `lag()`
- Fix: Fill with 1 or 2 leads where possible using `ifelse()` and `lag()`
- Fill with `store_avg` when the above fail
- Code is available in the code file -- a bunch of code like:

```{r, eval=F}
df_test <- df_test %>%
  arrange(Store, Dept, date) %>%
  group_by(Store, Dept) %>%
  mutate(naive_mean=ifelse(is.na(naive_mean), lag(naive_mean),naive_mean)) %>%
  ungroup()
```

```{r, echo=F, message=F, warning=F}
# there are a lot of scattered missing weeks -- fill with a lag first
df_test$naive_na <- is.na(df_test$naive_mean)
df_test <- df_test %>%
  arrange(Store, Dept, date) %>%
  group_by(Store, Dept) %>%
  mutate(naive_mean=ifelse(is.na(naive_mean), lag(naive_mean),naive_mean)) %>%
  ungroup()
df_test <- df_test %>%
  arrange(Store, Dept, date) %>%
  group_by(Store, Dept) %>%
  mutate(naive_mean=ifelse(is.na(naive_mean), lag(naive_mean,2),naive_mean)) %>%
  ungroup()
df_test <- df_test %>%
  arrange(Store, Dept, date) %>%
  group_by(Store, Dept) %>%
  mutate(naive_mean=ifelse(is.na(naive_mean), lead(naive_mean,1),naive_mean)) %>%
  ungroup()
df_test <- df_test %>%
  arrange(Store, Dept, date) %>%
  group_by(Store, Dept) %>%
  mutate(naive_mean=ifelse(is.na(naive_mean), lead(naive_mean,2),naive_mean)) %>%
  ungroup()
df_test$naive_mean <- ifelse(is.na(df_test$naive_mean), df_test$store_avg, df_test$naive_mean)
```

## Cleaning is done {data-background="../Backgrounds/coding.jpg" class="default"}

- Data is in order
    - No missing values where data is needed
    - Needed values created

```{r, fig.height=3}
df %>% 
  group_by(week, Store) %>%
  mutate(sales=mean(Weekly_Sales)) %>%
  slice(1) %>%
  ungroup() %>%
  ggplot(aes(y=sales, x=week, color=factor(Store))) +
  geom_line() + xlab("Week") + ylab("Sales for Store (dept average)") + 
  theme(legend.position="none")
```


# Tackling the problem {data-background="../Backgrounds/section.jpg" class="header"}

## First try {data-background="../Backgrounds/case.jpg" class="default"}

<div class="clearfix">
<div class="left">
- Ideal: Use last week to predict next week!

<img src="../Figures/red_x.png">

> No data for testing...

</div>
<div class="right">
- First instinct: try to use a linear regression to solve this

<img src="../Figures/green_check.png">

> We have this

</div>

## What to put in the model? {data-background="../Backgrounds/case.jpg" class="default"}

<img src="../Figures/wmt_weekly.png" height="500px">

## First model {data-background="../Backgrounds/case.jpg" class="default"}

```{r}
mod1 <- lm(Weekly_mult ~ factor(IsHoliday) + factor(markdown>0) +
                         markdown + Temperature +
                         Fuel_Price + CPI + Unemployment,
           data=df)
tidy(mod1)
glance(mod1)
```

## Prep submission and check in sample WMAE {data-background="../Backgrounds/case.jpg" class="default"}

```{r}
# Out of sample result
df_test$Weekly_mult <- predict(mod1, df_test)
df_test$Weekly_Sales <- df_test$Weekly_mult * df_test$store_avg

# Required to submit a csv of Id and Weekly_Sales
write.csv(df_test[,c("Id","Weekly_Sales")],
          "WMT_linear.csv",
          row.names=FALSE)

# track
df_test$WS_linear <- df_test$Weekly_Sales

# Check in sample WMAE
df$WS_linear <- predict(mod1, df) * df$store_avg
w <- wmae(actual=df$Weekly_Sales, predicted=df$WS_linear, holidays=df$IsHoliday)
names(w) <- "Linear"
wmaes <- c(w)
wmaes
```

## Performance for linear model {data-background="../Backgrounds/case.jpg" class="default exclude"}

<img src="../Figures/WMT_linear.png" width="700px">
<img src="../Figures/WMT_linear_rank.png" width="700px">

## Visualizing in sample WMAE {data-background="../Backgrounds/case.jpg" class="default"}

```{r fig.height=4}
wmae_obs <- function(actual, predicted, holidays) {
  abs(actual-predicted)*(holidays*5+1) / (length(actual) + 4*sum(holidays))
}
df$wmaes  <- wmae_obs(actual=df$Weekly_Sales, predicted=df$WS_linear,
                      holidays=df$IsHoliday)
ggplot(data=df, aes(y=wmaes, x=week, color=factor(IsHoliday))) + 
  geom_jitter(width=0.25) + xlab("Week") + ylab("WMAE")
```


## Back to the drawing board... {data-background="../Backgrounds/case.jpg" class="default"}

<img src="../Figures/wmt_weekly2.png" height="500px">

## Second model: Including week {data-background="../Backgrounds/case.jpg" class="default"}

```{r}
mod2 <- lm(Weekly_mult ~ factor(week) + factor(IsHoliday) + factor(markdown>0) +
                         markdown + Temperature +
                         Fuel_Price + CPI + Unemployment,
           data=df)
tidy(mod2)
glance(mod2)
```

## Prep submission and check in sample WMAE {data-background="../Backgrounds/case.jpg" class="default"}

```{r, message=F}
# Out of sample result
df_test$Weekly_mult <- predict(mod2, df_test)
df_test$Weekly_Sales <- df_test$Weekly_mult * df_test$store_avg

# Required to submit a csv of Id and Weekly_Sales
write.csv(df_test[,c("Id","Weekly_Sales")],
          "WMT_linear2.csv",
          row.names=FALSE)

# track
df_test$WS_linear2 <- df_test$Weekly_Sales

# Check in sample WMAE
df$WS_linear2 <- predict(mod2, df) * df$store_avg
w <- wmae(actual=df$Weekly_Sales, predicted=df$WS_linear2, holidays=df$IsHoliday)
names(w) <- "Linear 2"
wmaes <- c(wmaes, w)
wmaes
```

## Performance for linear model 2 {data-background="../Backgrounds/case.jpg" class="default exclude"}

<img src="../Figures/WMT_linear2.png" width="700px">
<img src="../Figures/WMT_linear2_rank.png" width="700px">

```{r, include=F}
wmaes_out <- c(4993.4, 5618.4)
names(wmaes_out) <- c("Linear", "Linear 2")
```

```{r}
wmaes_out
```

## Visualizing in sample WMAE {data-background="../Backgrounds/case.jpg" class="default"}

```{r, fig.height=4}
df$wmaes  <- wmae_obs(actual=df$Weekly_Sales, predicted=df$WS_linear2,
                      holidays=df$IsHoliday)
ggplot(data=df, aes(y=wmaes,
                    x=week,
                    color=factor(IsHoliday))) + 
  geom_jitter(width=0.25) + xlab("Week") + ylab("WMAE")
```

## Visualizing in sample WMAE by Store {data-background="../Backgrounds/case.jpg" class="default"}

```{r, fig.height=4}
ggplot(data=df, aes(y=wmae_obs(actual=Weekly_Sales, predicted=WS_linear2,
                               holidays=IsHoliday),
                    x=week,
                    color=factor(Store))) + 
  geom_jitter(width=0.25) + xlab("Week") + ylab("WMAE") + 
  theme(legend.position="none")
```

## Visualizing in sample WMAE by Dept {data-background="../Backgrounds/case.jpg" class="default"}

```{r, fig.height=4}
ggplot(data=df, aes(y=wmae_obs(actual=Weekly_Sales, predicted=WS_linear2,
                               holidays=IsHoliday),
                    x=week,
                    color=factor(Dept))) + 
  geom_jitter(width=0.25) + xlab("Week") + ylab("WMAE") + 
  theme(legend.position="none")
```

## Back to the drawing board... {data-background="../Backgrounds/case.jpg" class="default"}

<img src="../Figures/wmt_weekly3.png" height="500px">

## Third model: Including week x Store x Dept {data-background="../Backgrounds/case.jpg" class="default"}

```{r, eval=F}
mod3 <- lm(Weekly_mult ~ factor(week):factor(Store):factor(Dept) + factor(IsHoliday) + factor(markdown>0) +
                         markdown + Temperature +
                         Fuel_Price + CPI + Unemployment,
           data=df)
## Error: cannot allocate vector of size 606.8Gb
```

> ...

## Third model: Including week x Store x Dept {data-background="../Backgrounds/case.jpg" class="default"}

- Use `package:fixest`'s `feols()` -- it really is more efficient!

```{r, message=F}
library(fixest)
mod3 <- feols(Weekly_mult ~ markdown +
            Temperature +
            Fuel_Price +
            CPI +
            Unemployment | id, data=df)
tidy(mod3)
glance(mod3)
```

## Prep submission and check in sample WMAE {data-background="../Backgrounds/case.jpg" class="default"}

```{r, message=F}
# Out of sample result
df_test$Weekly_mult <- predict(mod3, df_test)
df_test$Weekly_Sales <- df_test$Weekly_mult * df_test$store_avg
# Replace NA values with store average
df_test <- df_test %>%
  mutate(Weekly_Sales = ifelse(is.na(Weekly_Sales), naive_mean, Weekly_Sales))


# Required to submit a csv of Id and Weekly_Sales
write.csv(df_test[,c("Id","Weekly_Sales")],
          "WMT_FE.csv",
          row.names=FALSE)

# track
df_test$WS_FE <- df_test$Weekly_Sales

# Check in sample WMAE
df$WS_FE <- predict(mod3, df) * df$store_avg
w <- wmae(actual=df$Weekly_Sales, predicted=df$WS_FE, holidays=df$IsHoliday)
names(w) <- "FE"
wmaes <- c(wmaes, w)
wmaes
```

## Performance for FE model {data-background="../Backgrounds/case.jpg" class="default exclude"}

<img src="../Figures/WMT_FE.png" width="700px">
<img src="../Figures/WMT_FE_rank.png" width="700px">

```{r, include=F}
wmaes_out <- c(4993.4, 5618.4, 3379.3)
names(wmaes_out) <- c("Linear", "Linear 2", "FE")
```
```{r}
wmaes_out
```

## Visualizing in sample WMAE {data-background="../Backgrounds/case.jpg" class="default"}

```{r, fig.height=4}
df$wmaes  <- wmae_obs(actual=df$Weekly_Sales, predicted=df$WS_FE,
                      holidays=df$IsHoliday)
ggplot(data=df, aes(y=wmaes,
                    x=week,
                    color=factor(IsHoliday))) + 
  geom_jitter(width=0.25) + xlab("Week") + ylab("WMAE")
```

## Maybe the data is part of the problem? {data-background="../Backgrounds/question.jpg" class="default"}

- What problems might there be for our testing sample?
    - What is different from testing to training?
- Can we fix them?
    - If so, how?

## Problems with the data {data-background="../Backgrounds/answer.jpg" class="default exclude"}

1. The holidays are not always on the same week
    - The Super Bowl is in weeks 6, 6, 7, *6*
    - Labor day isn't in our testing data at all!
    - Black Friday is in weeks 48, 47, and *47*
    - Christmas is in weeks 53, 52, and *52*
    - Manually adjust the data for these differences
2. Yearly growth -- we aren't capturing it, since we have such a small time span
    - We can manually adjust the data for this

> Code is in the code file -- a lot of `package:dplyr`

```{r, include=F}
# Function to map holidays
holidf <- function(df, years, weeks) {
  if(length(years) == 2) {
    years = c(years, 9999)
    weeks = c(weeks, 99)
  }
  df %>%
  filter(week(df$date) == weeks[1] & year(df$date) == years[1] |
         week(df$date) == weeks[2] & year(df$date) == years[2] |
         week(df$date) == weeks[3] & year(df$date) == years[3]) %>%
  select(Store,Dept,Weekly_Sales) %>%
  group_by(Store,Dept) %>%
  mutate(holiday_sales=mean(Weekly_Sales,rm.na=T)) %>%
  slice(1) %>%
  ungroup() %>%
  select(Store,Dept,holiday_sales) %>%
  as.data.frame()
}
# Add holiday shift to data
add_holiday <- function(df, holiday, wk) {
  q <- left_join(df, holiday)
  q <- q %>% transmute(Weekly_Sales=ifelse(week==wk,holiday_sales,Weekly_Sales))
  q[[1]]
}

# Start with our FE approach
df_test$Weekly_Sales <- df_test$WS_FE

# CHRISTMAS
# 2010: 53, 2011: 52, 2012: *52*
# Get a df with Christmas specific sales
s_xmas <- holidf(df, c(2010,2011), c(53,52))
s_xmas_m1 <- holidf(df, c(2010,2011), c(52,51))

df_test$Weekly_Sales <- add_holiday(df_test, s_xmas, 52)
df_test$Weekly_Sales <- add_holiday(df_test, s_xmas_m1, 51)

# BLACK FRIDAY 2010-11-26: 48; 2011-11-25: 47, 2012-11-23: *47*
s_bf <- holidf(df, c(2010,2011), c(48,47))

df_test$Weekly_Sales <- add_holiday(df_test, s_bf, 47)

# Note that the superbowl is weeks 6, 6, 7, *6*
s_sb <- holidf(df, c(2010,2011,2012), c(6,6,7))
s_sb_m1 <- holidf(df, c(2010,2011,2012), c(5,5,6))

df_test$Weekly_Sales <- add_holiday(df_test, s_sb, 7)
df_test$Weekly_Sales <- add_holiday(df_test, s_sb_m1, 6)

# Clean up any missing values added
df_test[is.na(df_test$Weekly_Sales),]$Weekly_Sales <- df_test[is.na(df_test$Weekly_Sales),]$naive_mean


# Calculate yearly growth
# A bit difficult since the data is a partial year, a full year, and a partial year
yg1 <- df %>%
  arrange(Store, year) %>%
  filter(year == 2010) %>%
  group_by(Store, year) %>%
  mutate(sales2010=mean(Weekly_Sales)) %>%
  slice(1) %>%
  ungroup() %>%
  select(Store, sales2010)
yg2 <- df %>%
  arrange(Store, year) %>%
  filter(date > as.Date("2011-02-05") & year == 2011) %>%
  group_by(Store, year) %>%
  mutate(sales2011a=mean(Weekly_Sales)) %>%
  slice(1) %>%
  ungroup() %>%
  select(Store, sales2011a)
yg3 <- df %>%
  arrange(Store, year) %>%
  filter(date < as.Date("2011-10-06") & year == 2011) %>%
  group_by(Store, year) %>%
  mutate(sales2011b=mean(Weekly_Sales)) %>%
  slice(1) %>%
  ungroup() %>%
  select(Store, sales2011b)
yg4 <- df %>%
  arrange(Store, year) %>%
  filter(year == 2012) %>%
  group_by(Store, year) %>%
  mutate(sales2012=mean(Weekly_Sales)) %>%
  slice(1) %>%
  ungroup() %>%
  select(Store, sales2012)
yg <- full_join(yg1,yg2) %>% full_join(yg3) %>% full_join(yg4)
yg <- yg %>%
  mutate(growth1=sales2011a/sales2010,
         growth2=sales2012/sales2011b,
         growth=ifelse(is.na(growth1),ifelse(is.na(growth2),1,growth2),ifelse(is.na(growth2),1,(growth1+growth2)/2))) %>%
  select(Store, growth)

# Add growth data to our df_test data frame
df_test <- left_join(df_test, yg)
df_test[df_test$year == 2012,]$Weekly_Sales <- df_test[df_test$year == 2012,]$Weekly_Sales * df_test[df_test$year == 2012,]$growth
df_test[df_test$year == 2013,]$Weekly_Sales <- df_test[df_test$year == 2013,]$Weekly_Sales * df_test[df_test$year == 2013,]$growth

write.csv(df_test[,c("Id","Weekly_Sales")], file="WMT_FE_shift.csv", row.names=FALSE)
df_test$WS_FE_shift <- df_test$Weekly_Sales

# BONUS: Ensembling
# Ensemble: Building multiple models and combining them into 1

# This example: add in a naive mean approach with shifting + growth
df_test$Weekly_Sales <- df_test$naive_mean
df_test$Weekly_Sales <- add_holiday(df_test, s_xmas, 52)
df_test$Weekly_Sales <- add_holiday(df_test, s_xmas_m1, 51)
df_test$Weekly_Sales <- add_holiday(df_test, s_bf, 47)
df_test$Weekly_Sales <- add_holiday(df_test, s_sb, 7)
df_test$Weekly_Sales <- add_holiday(df_test, s_sb_m1, 6)
df_test[is.na(df_test$Weekly_Sales),]$Weekly_Sales <- df_test[is.na(df_test$Weekly_Sales),]$naive_mean
df_test[df_test$year == 2012,]$Weekly_Sales <- df_test[df_test$year == 2012,]$Weekly_Sales * df_test[df_test$year == 2012,]$growth
df_test[df_test$year == 2013,]$Weekly_Sales <- df_test[df_test$year == 2013,]$Weekly_Sales * df_test[df_test$year == 2013,]$growth
write.csv(df_test[,c("Id","Weekly_Sales")], file="WMT_naivemean.csv", row.names=FALSE)
df_test$WS_naivemean <- df_test$Weekly_Sales

# Ensembles -- in this case, these don't work so well though.  Better with more models.  It ranks 222nd as opposed to 243rd worldwide
df_test$Weekly_Sales <- apply(df_test[,c("WS_FE_shift","WS_naivemean")],1,min)
#df_test$Weekly_Sales <- apply(df_test[,c("WS_FE_shift","WS_naivemean")],1,max)
#df_test$Weekly_Sales <- apply(df_test[,c("WS_FE_shift","WS_naivemean")],1,mean)

write.csv(df_test[,c("Id","Weekly_Sales")], file="WMT_ens.csv", row.names=FALSE)

```

## Performance overall {data-background="../Backgrounds/case.jpg" class="default exclude"}

<img src="../Figures/WMT_FE_shift.png" width="700px">
<img src="../Figures/WMT_FE_shift_rank.png" width="700px">

```{r, include=F}
wmaes_out <- c(4993.4, 5618.4, 3378.8, 3274.8)
names(wmaes_out) <- c("Linear", "Linear 2", "FE", "Shifted FE")
```
```{r}
wmaes_out
```

# End Matter {data-background="../Backgrounds/ending.jpg" class="header"}

## This was a real problem! {data-background="../Backgrounds/presentation.jpg" class="default"}

- Walmart provided this data back in 2014 as part of a recruiting exercise
    - <a href="https://www.kaggle.com/c/walmart-recruiting-store-sales-forecasting/leaderboard">Details here</a>
    - <a href="https://www.kaggle.com/c/walmart-recruiting-store-sales-forecasting/discussion/8125">Discussion of first place entry</a>
        - <a href="https://github.com/davidthaler/Walmart_competition_code">Code for first place entry</a>
    - <a href="https://www.kaggle.com/c/walmart-recruiting-store-sales-forecasting/discussion/8023">Discussion of second place entry</a>
- This is what the group project will be like
    - 4 to 5 group members tackling a real life data problem
    - You will have training data but testing data will be withheld
    - Submit on Kaggle

## Project deliverables {data-background="../Backgrounds/presentation.jpg" class="default"}

1. Kaggle submission
2. Your code for your submission, walking through what you did
3. A 15 minute presentation on the last day of class describing:
    - Your approach
4. A report discussing
    - Main points and findings
    - Exploratory analysis of the data used
    - Your model development, selection, implementation, evaluation, and refinement
    - A conclusion on how well your group did and what you learned in the process

## Packages used for these slides {data-background="../Backgrounds/coding.jpg" class="default stack"}

- `package:broom`
- `package:fixest`
- `package:kableExtra`
- `package:knitr`
- `package:lubridate`
- `package:magrittr`
- `package:revealjs`
- `package:tidyverse`

## References {data-background="../Backgrounds/books-old.jpg" class="default stack never"}

## Custom code {data-background="../Backgrounds/code.jpg" class="default stack never"}

<small style="width:100%">
```{r, eval=F}

```
</small>

## NOTES {class="never"}


