---
title: "ACCT 420: Project example"
author: 
  - name: Dr. Richard M. Crowley
    email: rcrowley@smu.edu.sg
    affiliation: https://rmc.link/
title-slide-attributes:
  data-background-video: "../Backgrounds/title.mp4"
  data-background-video-loop: "true"
  data-background-size: stretch
format:
  revealjs:
    theme: default
    css: quarto_white.css
    navigation-mode: vertical
    controls: true
    transition: slide
    background-transition: fade
    transition-speed: default
    width: 1536
    height: 864
    logo: ../Logos/logo2.png
    code-link: true
    code-line-numbers: false
    chalkboard:
      theme: whiteboard
    auto-stretch: false
revealjs-plugins:
  - attribution
execute:
  echo: true
  warning: false
  message: false
editor: source
---

# Weekly revenue prediction at Walmart {data-background-video="../Backgrounds/section.mp4" data-background-video-loop="true"}

<!--# Note that the downlit and xml2 pacakges are required to compile -->
<!--# Installed extensions include `attribution`, `qrcode`, and `material-icons` -->

```{r helpers, echo=FALSE, warning=FALSE, message=F}
library(knitr)
library(kableExtra)

#' Pretty formatted HTML tables
#' 
#' @param df The dataframe to format as a table
#' @param names Names to use for columns if not using the df column names. Vector
#' @param highlight_cols Columns to highlight. Default is c(1) for highlighting the first row. Use c() to remove.
#' @param highlight_rows Rows to highlight. Default is c() to not highlight any rows.
#' @param color_rows Rows to highlight in color. Default is c() to not highlight any rows.
#' @param highlight_end_rows Rows to highlight. Uses a reverse indexing where 1 is the last row, 2 is second to last, etc.
#' @param full Use to span the full width of a slide. FALSE by default.
#' @param fixed_header Whether the first row should be treated as a header row. TRUE by default.
html_df <- function(df, names=NULL, highlight_cols=c(1), highlight_rows=c(), color_rows=c(), highlight_end_rows=c(), full=F, fixed_header=T) {
  if(!length(names)) {
    names=colnames(df)
  }
  kbl(df,"html", col.names = names, align = c("l",rep('c',length(cols)-1))) %>%
    kable_paper(c("striped","hover"), full_width=full, fixed_thead=F, html_font = "\"Source Sans Pro\", Helvetica, sans-serif") %>%
    {if(length(highlight_cols)) column_spec(., highlight_cols,bold=T, background = "#ffffff99") else .} %>%
    {if(length(highlight_rows)) row_spec(., highlight_rows,bold=T, background = "#ffffff99") else .} %>%
    {if(length(color_rows)) row_spec(., color_rows,bold=T, background = "#aaaaff99") else .} %>%
    {if(length(highlight_end_rows)) row_spec(., nrow(df) + 1 - highlight_end_rows,bold=T, background = "#ffffff99") else .}
}
```

<!--# List packages here that are not being correctly highlighted -->
<!--# The usual cause is calling the library from a echo=FALSE cell -->

```{r}
#| include: false

library(tidyverse)
# Load in needed data
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")
```

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

> 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

::: {.callout-note}
## This is a real problem posed by Walmart

As such, the data is messy to work with. Real data is rarely clean.

:::

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

- 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"}

- 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"}

- 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"}

- 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"}

- 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"}

<!-- 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)      # To view results in a tidy manner
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` 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"}

```{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)
  # Output the data
  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"}

```{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"}

```{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()
```

![](../Figures/ifelse.png){width="500px" fig-align="center"}

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

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

- 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 for tracking across 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

# Id needed for submission
df_test$Id <- paste0(df_test$Store,'_',df_test$Dept,"_",df_test$date)
```

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

```{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"}

```{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 invalid 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"}

```{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"}

- 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"}

- 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-video="../Backgrounds/section.mp4" data-background-video-loop="true"}

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

:::: {.columns}

::: {.column width="50%"}
- Ideal: Use last week to predict next week!

![](../Figures/red_x.png){width="200px" fig-align="center"}

> No data for testing...
:::

::: {.column width="50%"}

- First instinct: try to use a linear regression to solve this

![](../Figures/green_check.png){width="200px" fig-align="center"}

> We have this

:::

::::


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

![](../Figures/wmt_weekly.png){height="500px" fig-align="center"}

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

```{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"}

```{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"}

![](../Figures/WMT_linear.png){width="900px" fig-align="center"}

![](../Figures/WMT_linear_rank.png){width="900px" fig-align="center"}

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

```{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"}

![](../Figures/wmt_weekly2.png){height="500px" fig-align="center"}

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

```{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"}

```{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"}

![](../Figures/WMT_linear2.png){width="900px" fig-align="center"}

![](../Figures/WMT_linear2_rank.png){width="900px" fig-align="center"}


```{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"}

```{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"}

```{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"}

```{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"}

![](../Figures/wmt_weekly3.png){height="500px" fig-align="center"}

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

```{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"}

- Use `{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"}

```{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))
```

```{r, message=F}
# 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"}

![](../Figures/WMT_FE.png){width="900px" fig-align="center"}

![](../Figures/WMT_FE_rank.png){width="900px" fig-align="center"}

```{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"}

```{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"}

- 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 `{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"}

![](../Figures/WMT_FE_shift.png){width="900px" fig-align="center"}

![](../Figures/WMT_FE_shift_rank.png){width="900px" fig-align="center"}

```{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-video="../Backgrounds/section.mp4"}

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

- 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"}

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/code.jpg" visibility="uncounted"}

- `{broom}`
- `{DT}`
- `{downlit}`
- `{fixest}`
- `{kableExtra}`
- `{knitr}`
- `{lubridate}`
- `{quarto}`
- `{revealjs}`
- `{tidyverse}`

## NOTES {class="never" visibility="hidden"}


