03_shiny_hierarchical_forecaster.Rmd

---
title: "Hierarchical Forecaster"
output: 
    flexdashboard::flex_dashboard:
        orientation: rows
        theme:
            bg: "#FFFFFF"
            fg: "#2c3e50"
            primary: "#2c3e50"
            base_font: !expr bslib::font_google("Oswald")
runtime: shiny
---
    
    ```{r setup, include=FALSE}
knitr::opts_chunk$set(
    echo    = FALSE,
    message = FALSE, 
    warning = FALSE
)

# IMPORTANT NOTE!!!
# INSTALL DEVELOPMENT VERSION OF RMARKDOWN AND CROSSTALK
# rmarkdown   * 2.6.6   2021-02-02 [1] Github (rstudio/rmarkdown@d8e7a15)

# Run These:
# remotes::install_github("rstudio/rmarkdown")
# remotes::install_github("rstudio/crosstalk")

library(shiny)
library(collapsibleTree)
library(plotly)
library(DT)
    
library(modeltime)
library(modeltime.ensemble)
library(tidymodels)
    
library(tidyverse)
library(timetk)

```


```{r}
hierarchy_tbl <- read_rds("m5-forecasting-accuracy/sales_sample_tbl.rds") %>%
    select(contains("id"))

full_data_tbl    <- read_rds("m5-forecasting-accuracy/full_data_tbl.rds")

test_forecast_ensemble_tbl <- read_rds("m5-forecasting-accuracy/test_forecast_ensemble_tbl.rds")

future_forecast_ensemble_tbl <- read_rds("m5-forecasting-accuracy/future_forecast_ensemble_tbl.rds")

purchases_summarized_tbl <- full_data_tbl %>%
    select(category, identifier, value) %>%
    group_by(category, identifier) %>%
    summarise(value = sum(value, na.rm = T)) %>%
    ungroup() %>%
    filter(category == 'item_id') %>%
    left_join(hierarchy_tbl, by = c("identifier" = "item_id")) %>%
    select(-id) 

indicator_options <- full_data_tbl %>%
    distinct(category, identifier) %>%
    mutate(category = factor(
        category, 
        levels = c("all_stores_id", "state_id", "store_id", 
                   "cat_id", "dept_id", "item_id"))
    ) %>%
    arrange(category, identifier) %>%
    pull(identifier)
```



# Product Exploration

## Column {.sidebar}

#### What it does

Forecast any level within a __Product Hierarchy__.

<hr>
    
#### How it works
    
```{r}
shiny::selectInput(
    "indicator", 
    label     = "Select a Hierarchy to Forecast",
    choices   = indicator_options, 
    selectize = TRUE
)

shiny::radioButtons(
    inputId  = "lookback",
    label    = "Select a Look Back (Time Zoom)",
    choices  = c("3 months", "6 months", "12 months", "2 years"),
    selected = "2 years",
    inline   = FALSE
)

```

<hr>

Created in __Learning Lab 50: Hierarchical Forecasting.__ 

Learn more at [Business Science](https://www.business-science.io/)



## Column 1

### Product Hierarchy


```{r}
renderCollapsibleTree({
    purchases_summarized_tbl %>%
        # filter(identifier %in% input$indicator) %>%
        collapsibleTree(
            hierarchy = c("state_id", "store_id", "cat_id", "dept_id", "identifier"),
            attribute = "value",
            root      = "All Stores",
            aggFun    = sum, 
            nodeSize  = "value",
            tooltip   = TRUE, 
            fontSize  = 16
        )
})
```

## Row {.tabset .tabset-fade}

### Predicted Forecast (Next 28-Days)

```{r}
renderPlotly({
    future_forecast_ensemble_tbl %>%
    
        # FILTERS 
        filter(identifier %in% input$indicator) %>%
        
        group_by(identifier) %>%
        
        # Focus on end of series
        filter_by_time(
            .start_date = last(date) %-time% input$lookback, 
            .end_date = "end"
        ) %>%
        
        plot_modeltime_forecast(
            .facet_ncol         = 2, 
            .conf_interval_show = TRUE,
            .interactive        = TRUE
        )
})

```


### Test Forecast

```{r}
renderPlotly({
    test_forecast_ensemble_tbl %>%
    
        # FILTERS 
        filter(identifier %in% input$indicator) %>%
        
        group_by(identifier) %>%
        
        # Focus on end of series
        filter_by_time(
            .start_date = last(date) %-time% input$lookback, 
            .end_date = "end"
        ) %>%
        
        plot_modeltime_forecast(
            .facet_ncol         = 2, 
            .conf_interval_show = TRUE,
            .interactive        = TRUE
        )
})

```

### Test Accuracy

```{r}
accuracy_by_identifier_tbl <- test_forecast_ensemble_tbl %>%
    select(category, identifier, .model_desc, .index, .value) %>%
    pivot_wider(
        names_from   = .model_desc,
        values_from  = .value
    ) %>%
    drop_na() %>%
    rename(PREDICTION = 5) %>%
    group_by(category, identifier) %>%
    summarize_accuracy_metrics(
        truth      = ACTUAL, 
        estimate   = PREDICTION, 
        metric_set = default_forecast_accuracy_metric_set()
    )

renderDataTable({
    df <- accuracy_by_identifier_tbl %>%
        # FILTERS 
        filter(identifier %in% input$indicator) %>%
        mutate(across(c(mae, mape, rmse, smape), ~ round(., 1))) %>%
        mutate(across(c(mase, rsq), ~ round(., 3))) 
    
    datatable(
        data = df, 
        options = list(
          scrollX = TRUE, 
          scrollY = TRUE,
          dom     = 'Bfrtip',
          buttons = c('copy', 'csv', 'excel')
        )
    )
})
```