Data-Analysis-Jupyter/weight_loss_challenge/weight_challenge_results.Rmd

---
title: "2017 Weight Challenge"
author: "Will Koehrsen"
date: "January 7, 2018"
output: html_document
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
library(googlesheets)
library(tidyverse)
library(slackr)
library(ggthemes)
library(gganimate)
library(prophet)
```


# Formatting and Cleaning Weights

```{r}
weights <- read_csv('weight_data.csv')
# Convert to date only
craig_weights <- weights %>% dplyr::filter(name == 'Craig') %>% arrange(date) %>%
  dplyr::filter(date < as.Date('2018-01-07'))
will_weights <- weights %>% dplyr::filter(name == 'Will') %>% arrange(date) %>%
  dplyr::filter(date < as.Date('2018-01-07'))

weights <- rbind(craig_weights, will_weights)
```

# Data Manipulation
We want to have a column representing the weight changes. Therefore we first need
to find the starting weighting for both participants. 

```{r}
# Baseline weights
craig_start <- craig_weights$weight[1]
will_start <- will_weights$weight[1]

# Create a column of weight changes
weight_change <- function(row) {
  if(row[2] == 'Craig') {
    return(craig_start - as.numeric(row[3]))
  } else {
    return(as.numeric(row[3]) - will_start)
  }
}
weights$change <- apply(weights, MARGIN = 1, FUN = weight_change)

# Create a column of percentage weight changes
pct_weight_change <- function(row) {
   if (row[2] == 'Craig') {
    return(100 * (craig_start - as.numeric(row[3])) / craig_start)
  } else {
    return(100 * (as.numeric(row[3]) - will_start) / will_start)
  }
}

weights$change_pct <- apply(weights, MARGIN = 1, FUN = pct_weight_change)

```


# Plots 

Start off with a simple graph of the raw weights. We need two separate
axes to represent the varying scales.

```{r}
ggplot(weights, aes(date)) + 
    geom_jitter(data = dplyr::filter(weights, name == 'Craig'), 
                aes(y = weight, col = "Craig"),shape = 2, size = 1.2) +
    geom_line(data = dplyr::filter(weights, name == 'Craig'), 
              aes(y = weight, col = "Craig"), lwd = 1.2) +
    geom_jitter(data = dplyr::filter(weights, name == 'Will'), 
                aes(y = 1.9 * weight, col = "Will"),shape = 2, size = 1.2) +
    geom_line(data = dplyr::filter(weights, name == 'Will'), 
              aes(y = 1.9 * weight, col = "Will"), lwd = 1.2) +
    scale_y_continuous(sec.axis = sec_axis(~.*(1/1.9), name = 'Will Weight (lbs)', 
                                           breaks = seq(115, 145, 10)), 
                       breaks = seq(215, 280, 10), limits = c(215, 275)) + 
    scale_color_manual(values = c("midnightblue", "red3"), labels = c('Craig', 'Will')) + 
    xlab("") + ylab('Craig Weight (lbs)') + 
    labs(color = "Name") + ggtitle("Weight Challenge") + 
    theme(axis.text.y = element_text(color = "midnightblue"), 
          axis.text.y.right = element_text(color = 'red3')) + 
  theme_hc(14)


ggplot(weights, aes(date)) + 
    geom_point(data = dplyr::filter(weights, name == 'Craig'), 
                aes(y = weight, col = "Craig"), size = 2.5) +
    geom_point(data = dplyr::filter(weights, name == 'Will'), 
                aes(y = 1.82 * weight, col = "Will"),size = 2.5) +
    scale_y_continuous(sec.axis = sec_axis(~.*(1/1.82), name = 'Will Weight (lbs)', 
                                           breaks = seq(110, 140, 5)), 
                       breaks = seq(215, 255, 5), limits = c(215, 255)) + 
    scale_color_manual(values = c('midnightblue', 'red3'), labels = c('Craig', 'Will')) + 
    xlab("") + ylab('Craig Weight (lbs)') + 
    labs(color = "") + ggtitle("Full Weight Challenge Results")  + 
  theme_classic(14) + 
    theme(axis.text.y = element_text(color = "midnightblue"), 
          axis.text.y.right = element_text(color = 'red3'), 
          axis.title.y = element_text(color = 'midnightblue'),
          axis.title.y.right = element_text(color = 'red3'),
          legend.position = 'bottom', 
          plot.title = element_text(hjust = 0.5, size = 16),
          axis.text.x = element_text(color = 'black')) + 
  geom_smooth(data = dplyr::filter(weights, name == 'Craig'), 
                aes(y = weight, col = "Craig"), lwd = 1.6) + 
  geom_smooth(data = dplyr::filter(weights, name == 'Will'), 
                aes(y = 1.82 * weight, col = "Will"), lwd = 1.6) 
```

We can make plots of the changes in absolute terms to see who
was winning at each stage.

```{r}
# Absolute change
ggplot(weights, aes(date, change, group = name, col = name)) + 
    geom_point(size = 2) + 
  scale_color_manual(values = c('midnightblue', 'red3'), labels = c('Craig', 'Will')) +
    xlab('') + ylab('Change (lbs)') + ggtitle('Absolute Weight Change') + 
    labs(color = '') + coord_cartesian(ylim = c(0, 20)) + 
  theme_classic(14) + theme(legend.position = 'bottom', 
                            plot.title = element_text(hjust = 0.5,
                                                      size = 16),
                            axis.text = element_text(color = 'black'),
                            panel.grid.major.y = element_line()) + 
  geom_smooth()

# Percentage change
ggplot(weights, aes(date, round(change_pct, 1), group = name, col = name)) + 
    geom_jitter(size = 2) + geom_smooth() + 
  scale_color_manual(values = c('midnightblue', 'red3'), labels = c('Craig', 'Will')) +
    xlab('') + ylab('Change %') + ggtitle('Absolute Weight Change Percentage') + 
    labs(color = '') + coord_cartesian(ylim = c(0, 10)) + 
  theme_classic(14) + 
  theme(legend.position = 'bottom', 
                            plot.title = element_text(hjust = 0.5,
                                                      size = 16),
                            axis.text = element_text(color = 'black'),
                            panel.grid.major.y = element_line())

```

Quantitative results.

```{r}
craig_final <- dplyr::filter(weights, name == 'Craig' & date == '2018-01-06')
will_final <- dplyr::filter(weights, name == 'Will' & date == '2018-01-06')

final_results <- rbind(craig_final, will_final) %>% select(name, weight, change,
                                                           change_pct)

knitr::kable(final_results)
```

# Modeling

## Linear Models

```{r}
# Days since start of competition
craig_weights$days <- as.numeric(lubridate::yday(craig_weights$date) - 
                                   lubridate::yday(craig_weights$date)[1])
# Create a simple linear model
craig_lm <- lm(weight ~ days, craig_weights)


will_weights$days <- as.numeric(lubridate::yday(will_weights$date) - 
                                  lubridate::yday(will_weights$date)[1])
will_lm <- lm(weight ~ days, will_weights)

summary(craig_lm)

summary(will_lm)
```
Plots of Linear Models

```{r}
ggplot(weights, aes(date)) + 
    geom_point(data = dplyr::filter(weights, name == 'Craig'), 
                aes(y = weight, col = "Craig"), size = 2.5) +
    geom_point(data = dplyr::filter(weights, name == 'Will'), 
                aes(y = 1.82 * weight, col = "Will"),size = 2.5) +
    scale_y_continuous(sec.axis = sec_axis(~.*(1/1.82), name = 'Will Weight (lbs)', 
                                           breaks = seq(110, 140, 5)), 
                       breaks = seq(215, 255, 5), limits = c(215, 255)) + 
    scale_color_manual(values = c('midnightblue', 'red3'), labels = c('Craig', 'Will')) + 
    xlab("") + ylab('Craig Weight (lbs)') + 
    labs(color = "") + ggtitle("Weight Challenge Results with Linear Model")  + 
  theme_classic(14) + 
    theme(axis.text.y = element_text(color = "midnightblue"), 
          axis.text.y.right = element_text(color = 'red3'), 
          axis.title.y = element_text(color = 'midnightblue'),
          axis.title.y.right = element_text(color = 'red3'),
          legend.position = 'bottom', 
          plot.title = element_text(hjust = 0.5, size = 16),
          axis.text.x = element_text(color = 'black')) + 
  geom_smooth(data = dplyr::filter(weights, name == 'Craig'), method = 'lm',
                aes(y = weight, col = "Craig"), lwd = 1.6) + 
  geom_smooth(data = dplyr::filter(weights, name == 'Will'), method = 'lm', 
                aes(y = 1.82 * weight, col = "Will"), lwd = 1.6) 

```

Predictions for January 1, 2019

```{r}
# Find number of days between start of competition January 1, 2019
days <- as.numeric(as.Date('2019-01-01') - craig_weights$date[1])

craig_prediction <- predict(craig_lm, 
                           data.frame(days = days, name = 'Craig', plot = TRUE),
                           interval = 'predict')

will_prediction <- predict(will_lm, 
                           data.frame(days = days, name = 'Will', plot = TRUE),
                           interval = 'predict')

```

## Generalized Additive Model

```{r}
craig_weights$ds <- craig_weights$date
craig_weights$y <- craig_weights$weight
craig_gam <- prophet::prophet(craig_weights)

will_weights$ds <- will_weights$date
will_weights$y <- will_weights$weight
will_gam <- prophet::prophet(will_weights)

craig_forecast <- prophet::make_future_dataframe(craig_gam, periods = 365)
craig_forecast <- predict(craig_gam, craig_forecast)
prophet::prophet_plot_components(craig_gam, craig_forecast) 

will_forecast <- prophet::make_future_dataframe(will_gam, periods = 365)
will_forecast <- predict(will_gam, will_forecast)
prophet::prophet_plot_components(will_gam, will_forecast)

will_forecast$name <- 'Will'
craig_forecast$name <- 'Craig'
forecast <- rbind(will_forecast, craig_forecast)
```

Predictions for January 1, 2018

```{r}
short_days <- as.numeric(as.Date('2018-01-01') - as.Date('2017-11-01'))
craig_short_gam <- prophet::prophet(df = dplyr::filter(craig_weights, date < '2017-11-01'))
craig_short_forecast <- prophet::make_future_dataframe(craig_short_gam, periods = short_days)
craig_short_forecast <- predict(craig_short_gam, craig_short_forecast)

will_short_gam <- prophet::prophet(df = dplyr::filter(will_weights, date < '2017-11-01'))
will_short_forecast <- prophet::make_future_dataframe(will_short_gam, periods = short_days)
will_short_forecast <- predict(will_short_gam, will_short_forecast)

prophet::prophet_plot_components(craig_short_gam, craig_short_forecast)


ggplot(craig_short_forecast, aes(x = ds, y = trend)) + 
  geom_ribbon(data = dplyr::filter(craig_short_forecast, ds >= '2017-11-01'),
                                  aes(ymin = trend_lower, ymax = trend_upper), 
              color = 'black', lwd = 1, fill = 'gainsboro') + 
  geom_line(color = 'red3', lwd = 1.8) + theme_classic(14) + 
   xlab('Date') + ylab('Weight (lbs)') + 
  ggtitle('Craig GAM Prediction for Jan 1, 2018') + 
  theme(axis.text = element_text(color = 'black'), 
        plot.title = element_text(hjust = 0.5, size = 18))

ggplot(will_short_forecast, aes(x = ds, y = trend)) + 
  geom_ribbon(data = dplyr::filter(will_short_forecast, ds >= '2017-11-01'),
                                  aes(ymin = trend_lower, ymax = trend_upper), 
              color = 'black', lwd = 1, fill = 'gainsboro') + 
  geom_line(color = 'red3', lwd = 1.8) + theme_classic(14) + 
   xlab('Date') + ylab('Weight (lbs)') + 
  ggtitle('Will GAM Prediction for Jan 1, 2018') + 
  theme(axis.text = element_text(color = 'black'), 
        plot.title = element_text(hjust = 0.5, size = 18))
```

Predictions for Jan 1, 2019

```{r}
ggplot(craig_forecast, aes(x = ds, y = trend)) + 
  geom_ribbon(data = dplyr::filter(craig_forecast, ds >= '2018-01-06'),
                                  aes(ymin = trend_lower, ymax = trend_upper), 
              color = 'black', lwd = 1, fill = 'gainsboro') + 
  geom_line(color = 'red3', lwd = 1.8) + theme_classic(14) + 
   xlab('Date') + ylab('Weight (lbs)') + 
  ggtitle('Craig GAM Prediction for Jan 1, 2019') + 
  theme(axis.text = element_text(color = 'black'), 
        plot.title = element_text(hjust = 0.5, size = 18))

ggplot(will_forecast, aes(x = ds, y = trend)) + 
  geom_ribbon(data = dplyr::filter(will_forecast, ds >= '2018-01-06'),
                                  aes(ymin = trend_lower, ymax = trend_upper), 
              color = 'black', lwd = 1, fill = 'gainsboro') + 
  geom_line(color = 'red3', lwd = 1.8) + theme_classic(14) + 
   xlab('Date') + ylab('Weight (lbs)') + 
  ggtitle('Will GAM Prediction for Jan 1, 2019') + 
  theme(axis.text = element_text(color = 'black'), 
        plot.title = element_text(hjust = 0.5, size = 18))


```


Generalized Additive Model Graphs

```{r}

ggplot(forecast, aes(x = as.Date(ds))) + 
  geom_line(data = dplyr::filter(forecast, ds < '2018-01-07' & name == 'Craig'), 
                aes(y = trend, col = "Craig"), size = 1.4) + 
  geom_line(data = dplyr::filter(forecast, ds < '2018-01-07' & name == 'Will'),
              aes(y = 1.82 * trend, col = "Will"),size = 1.4) + 
    scale_y_continuous(sec.axis = sec_axis(~.*(1/1.82), name = 'Will Weight (lbs)',
                                           breaks = seq(110, 140, 5)),
                       breaks = seq(215, 255, 5), limits = c(215, 255)) +
    scale_color_manual(values = c('midnightblue', 'red3'), labels = c('Craig', 'Will')) +
    xlab("") + ylab('Craig Weight (lbs)') +
    labs(color = "") + ggtitle("Overall Trends")  +
  theme_classic(14) +
    theme(axis.text.y = element_text(color = "midnightblue"),
          axis.text.y.right = element_text(color = 'red3'),
          axis.title.y = element_text(color = 'midnightblue'),
          axis.title.y.right = element_text(color = 'red3'),
          legend.position = 'bottom',
          plot.title = element_text(hjust = 0.5, size = 16),
          axis.text.x = element_text(color = 'black'))

craig_weekly_forecast <- dplyr::filter(forecast, name == 'Craig')[1:7, c('name', 'weekly')]
will_weekly_forecast <- dplyr::filter(forecast, name == 'Will')[1:7, c('name', 'weekly')]
weekly_forecast <- rbind(craig_weekly_forecast, will_weekly_forecast)
weekly_forecast$day <- factor(rep(c('Sun', 'Mon', 'Tues', 'Wed', 'Thur', 'Fri', 'Sat'), 2), 
                              levels = c('Mon', 'Tues', 'Wed', 'Thur', 'Fri', 'Sat', 'Sun'))

ggplot(weekly_forecast, aes(x = day, y = weekly, color = name)) + 
  geom_line(aes(group = name), size = 1.4) + geom_point(size = 2) +
    scale_color_manual(values = c('midnightblue', 'red3'), labels = c('Craig', 'Will')) +
    xlab("") + ylab('Change (lbs)') +
    labs(color = "") + ggtitle("Weekly Weight Trends")  +
  theme_classic(14) +
    theme(axis.text = element_text(color = "black"),
          axis.title = element_text(color = 'black'),
          legend.position = 'bottom',
          plot.title = element_text(hjust = 0.5, size = 16)) + 
  scale_y_continuous(lim = c(-1.0, 1.0), breaks = seq(-1.0, 1.0, 0.25))

```
Contrast models with reality
```{r}
ggplot(craig_short_forecast, aes(x = ds, y = trend)) + 
  geom_ribbon(data = dplyr::filter(craig_short_forecast, ds >= '2017-11-01'),
                                  aes(ymin = trend_lower, ymax = trend_upper), 
              color = 'black', lwd = 1, fill = 'gainsboro') + 
  geom_line(aes(color = 'predicted'), lwd = 1.8) + theme_classic(14) + 
   xlab('Date') + ylab('Weight (lbs)') + 
  ggtitle('Craig Predicted vs Actual') + 
  theme(axis.text = element_text(color = 'black'), 
        plot.title = element_text(hjust = 0.5, size = 18)) + 
  geom_point(data = dplyr::filter(weights, name == 'Craig' & date <= '2018-01-01'), 
                aes(x = as.POSIXct(date), y = weight, 
                    col = 'actual'), size = 2) + labs(color = '') + 
  scale_color_manual(values = c('red3', 'darkgreen'))

ggplot(will_short_forecast, aes(x = ds, y = trend)) + 
  geom_ribbon(data = dplyr::filter(will_short_forecast, ds >= '2017-11-01'),
                                  aes(ymin = trend_lower, ymax = trend_upper), 
              color = 'black', lwd = 1, fill = 'gainsboro') + 
  geom_line(aes(color = 'predicted'), lwd = 1.8) + theme_classic(14) + 
   xlab('Date') + ylab('Weight (lbs)') + 
  ggtitle('Will Predicted vs Actual') + 
  theme(axis.text = element_text(color = 'black'), 
        plot.title = element_text(hjust = 0.5, size = 18)) + 
  geom_point(data = dplyr::filter(weights, name == 'Will' & date <= '2018-01-01'), 
                aes(x = as.POSIXct(date), y = weight, 
                    col = 'actual'), size = 2) + labs(color = '') + 
  scale_color_manual(values = c('red3', 'darkgreen'))
```
# Animations

One of the most rewarding parts of a data analysis is animations! 

```{r}
library(gganimate)
weights$week <- lubridate::week(weights$date)
weights[which(lubridate::year(weights$date) == '2018'), ]$week <- 53
craig_trend <- dplyr::filter(craig_forecast, ds <= '2018-01-06')$trend
will_trend <- dplyr::filter(will_forecast, ds <= '2018-01-06')$trend

craig_trend_pct <- sapply(craig_trend, function(x) {return( abs(100 * (x - craig_start) / craig_start))})
will_trend_pct <- sapply(will_trend, function(x) {return ( 100 * (x - will_start) / will_start)})
weights$trend <- c(craig_trend, will_trend)
weights$trend_pct_change <- c((craig_trend_pct), will_trend_pct)

p <- ggplot(weights, aes(date, round(change_pct, 1), group = name, col = name, 
       frame = week, cumulative = TRUE)) + 
    geom_jitter(size = 2)  + 
  geom_line(aes(date, y = trend_pct_change), lwd = 2) + 
  scale_color_manual(values = c('midnightblue', 'red3'), labels = c('Craig', 'Will')) +
    xlab('') + ylab('Change %') + ggtitle('Absolute Weight Change Percentage') + 
    labs(color = '') + coord_cartesian(ylim = c(0, 10)) + 
  theme_classic(14) + 
  theme(legend.position = 'bottom', 
                            plot.title = element_text(hjust = 0.5,
                                                      size = 20),
                            axis.text = element_text(color = 'black',
                                                     size = 16),
        axis.title = element_text(color = 'black', size = 18), 
        legend.text = element_text(size = 16))

gganimate(p, filename = 'animated_weight_change.gif', saver = 'gif', 
          interval = 0.4, title_frame = FALSE, fig.height = 4)
```