parking_countdown.R

library(lubridate)
library(tidyverse)
# data ----
full_dat <- data.frame(
  dt = mdy(c('9/19/16', '2/27/17', '4/9/18', '9/17/18', '2/25/19', '8/5/2019',
             '1/13/2020', '6/22/2020')),
  num = c(2188,1833,1302,1171,1067,988, 892, 831)
)
obs <- nrow(full_dat)
holdout_days <- 2
full_dat$train_rows <- 1:obs %in% 1:(obs-holdout_days)
dat <- filter(full_dat, train_rows==T)


# models ----
# linear model
my_lm <- lm(dat$num ~ as.numeric(dat$dt - dat$dt[1]))
days_to_zero <- my_lm$coefficients[1] / (-my_lm$coefficients[2])
zero_day <- ymd(dat$dt[1] + days_to_zero)

# exponential model
dat$nth_day <- as.numeric(dat$dt - dat$dt[1] + 1)
exp_lm <- lm(1/num ~ nth_day, data=dat)
top_of_list_day <- 
  dat$dt[1] +
  (1 - coef(exp_lm)['(Intercept)']) / coef(exp_lm)['nth_day']

# add forward projection
exp_pred <- data.frame(dt = seq.Date(from=dat$dt[1], to=zero_day, by='day'))
exp_pred$nth_day = with(exp_pred, as.numeric(dt - dt[1] + 1))
exp_pred$num_hat <- 1/predict(exp_lm, newdata = exp_pred)

# plot ----
ggplot(dat, aes(dt, num)) +
  geom_point(data=full_dat, size=5, aes(shape=train_rows)) +
  geom_hline(yintercept = 0, color='grey50') +
  
  # linear
  geom_smooth(method='lm', se=F, fullrange=T,
              color='grey20', linetype='dotted') +
  annotate('text', 
           x = zero_day,
           y = -100,
           label = paste0('linear prediction: ', zero_day), 
           hjust=1,
           color='grey20', size=3) +
  
  # exponential 
  geom_line(data=exp_pred, aes(y=num_hat), color='blue') +
  annotate('text', 
           x = zero_day,
           y = full_dat$num[obs],
           label = glue::glue('exponential prediction:\n',
                              'in the year {year(top_of_list_day)}'), 
           hjust=1, vjust=1.5,
           color='blue', size=3) +
  ylim(3000,-200) +
  scale_x_date(limits = c(min(dat$dt), zero_day)) +
  scale_shape_manual(values = c(21, 19), guide=F) +
  theme_light() +
  theme(plot.title = element_text(face='bold')) +
  labs(title= 'When will we get a BART parking spot?',
       subtitle = glue::glue('Trendlines trained on all but the last ',
                             '{holdout_days} observation(s)'),
       y='Waitlist #', x='Date')

Linear trend still fits well, but est date now pushed back a few months :/

Well, this is looking grim