Comparing prediction, human intervention and actual

It is common to have machine learning algorithms learn from the variance between actual and predictions but I have seen less examples where human intervention is accounted for as well.

What I am interested in measuring is;

  1. A predicted course of action
  2. An adjusted course of action, that has been confirmed by a human
  3. The actual events that occur

Today I am going to create a simple scenario that outlines activity over a single calendar year. I’m going to use a simplified version of the kind of information I use in Deep Work Supervisor - daily events of ‘deep work’.

install.packages("truncnorm", repos="http://cran.rstudio.com/")
## Installing package into '/Users/williambidstrup/Library/R/3.5/library'
## (as 'lib' is unspecified)
## 
## The downloaded binary packages are in
##  /var/folders/dj/whwc1h4d2hq8w8qg0dhykkbw0000gn/T//RtmpnjHQHQ/downloaded_packages
library(here)
## here() starts at /Users/williambidstrup/Documents/GitHub/dse_live
library(tidyverse)
## ── Attaching packages ─────────────────────────────────────────────────────────────────────────────────── tidyverse 1.2.1 ──
## ✔ ggplot2 3.0.0     ✔ purrr   0.2.5
## ✔ tibble  1.4.2     ✔ dplyr   0.7.6
## ✔ tidyr   0.8.1     ✔ stringr 1.3.1
## ✔ readr   1.1.1     ✔ forcats 0.3.0
## ── Conflicts ────────────────────────────────────────────────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
library(padr)
library(truncnorm)

First I will create the year with padr.

dates <- as.Date(c("2019-01-01", "2019-01-02", "2019-12-30", "2019-12-31")) 
dates <- as.data.frame(dates)
dates  <- dates %>%
  pad()
## pad applied on the interval: day

I add three activities with a random amount of hours on each day.

dates$Activity_A <- round(rtruncnorm(n=365, a=0, b=4, mean=4, sd=3))
dates$Activity_B <- round(rtruncnorm(n=365, a=0, b=4, mean=3, sd=1))
dates$Activity_C <- round(rtruncnorm(n=365, a=0, b=4, mean=2, sd=2))

Gather into a single column which will be called the ‘predicted’ scenario. Obviously this is not a prediction, I’m calling it this to refer to the set of inputs that might have come from a prediction

dates <- dates %>%
  gather("activity", "predicted_hours", 2:4)

Now replicate the steps above to create the ‘human input’ hours and ‘actual’.

human_input <- as.Date(c("2019-01-01", "2019-01-02", "2019-12-30", "2019-12-31")) %>%
  as.data.frame() %>%
  pad()
## pad applied on the interval: day
# Change parameters in rtruncnorm
human_input$Activity_A <- round(rtruncnorm(n=365, a=0, b=4, mean=1, sd=2))
human_input$Activity_B <- round(rtruncnorm(n=365, a=0, b=4, mean=2, sd=1))
human_input$Activity_C <- round(rtruncnorm(n=365, a=0, b=4, mean=3, sd=1))

human_input <- human_input %>%
  gather("activity", "human_hours", 2:4)

names(human_input) <- c("dates", "activity", "human_hours")

To make the ‘actual’ set I need to make sure future dates are zero. Here I am considering the future to be post June 10th 2019.

actual_input <- as.Date(c("2019-01-01", "2019-01-02", "2019-12-30", "2019-12-31")) %>%
  as.data.frame() %>%
  pad()
## pad applied on the interval: day
# Change parameters in rtruncnorm
actual_input$Activity_A <- round(rtruncnorm(n=365, a=0, b=4, mean=1, sd=2))
actual_input$Activity_B <- round(rtruncnorm(n=365, a=0, b=4, mean=2, sd=1))
actual_input$Activity_C <- round(rtruncnorm(n=365, a=0, b=4, mean=3, sd=1))

actual_input <- actual_input %>%
  gather("activity", "actual_hours", 2:4)

names(actual_input) <- c("dates", "activity", "actual_hours")

# Filter out half of the year (to simulate full year not yet reached in actual)
actual_input_future <- actual_input %>%
  filter(dates >= "2019-06-10")

# Make future hours zero
actual_input_future$actual_hours <- 0
rm(future)
## Warning in rm(future): object 'future' not found
# Subset actual to past only
actual_input_past <- actual_input[!(actual_input$dates %in% actual_input_future$dates), ]

# Join past and future
actual_input <- actual_input_past %>%
  bind_rows(actual_input_future)

So now I have three identically sized data frames, each representing a number of hours for each of three activities across a whole year. I will combine them into a master data frame which can be used for analysis.

combined <- dates %>%
  left_join(human_input, by = c("dates", "activity")) %>%
  left_join(actual_input, by = c("dates", "activity"))

Which was better? Human or prediction? First tidy the data frame.

combined_tidy <- combined %>%
  gather("method", "hours", 3:5)

This plot shows a trend line of each method. It’s easy to see the differences.

ggplot(data = combined_tidy, aes(x = dates, y = hours, col = method, group = method)) +
  geom_smooth(se = FALSE) +
  facet_grid(. ~ activity) +
  theme_minimal() +
  labs(title = "Comparison of prediction, human and actual estimate hours per day per activity",
       subtitle = "As of June 11th 2019")
## `geom_smooth()` using method = 'loess' and formula 'y ~ x'

What might be more interesting is measuring the variance between actual and human or predicted.

combined$human_err <- (abs(combined$human_hours - combined$actual_hours)) / combined$actual_hours
combined$prediction_err <- (abs(combined$predicted_hours - combined$actual_hours)) / combined$actual_hours


combined$winner <- ifelse(combined$human_err > combined$prediction_err, "prediction_better",
                      ifelse(combined$human_err < combined$prediction_err, "human_better",
                             ifelse(combined$human_err == combined$prediction_err, "tie",
                                    ifelse(combined$human_err == Inf | combined$prediction_err == Inf, "infinitely_wrong", "other"))))

summary(as.factor(combined$winner))
##      human_better prediction_better               tie              NA's 
##               157               124               734                80
combined_tidy_error <- combined %>%
  select("dates", "activity", "human_err", "prediction_err") %>%
  gather("method", "error", 3:4)
ggplot(data = combined_tidy_error, aes(x = dates, y = error, col = method)) +
  geom_point(alpha = 0.2) +
  geom_smooth()
## `geom_smooth()` using method = 'gam' and formula 'y ~ s(x, bs = "cs")'
## Warning: Removed 1300 rows containing non-finite values (stat_smooth).
## Warning: Removed 84 rows containing missing values (geom_point).