projecting dates of NSERC discovery grant results

nserc_dates.R

library(tidyverse)
this_year <- 2022
(df <- read.table(text="
2021 April 14
2020 April 23
2019 April 11
2018 April 13
2017 April 12
2016 April 7
2015 April 1
2014 April 4
2013 March 21
")
    %>% transmute(
            year=V1,
            date=lubridate::ymd(paste(this_year,V2,V3)))
)


gg0 <- (ggplot(df,aes(year,date))
  + expand_limits(x=this_year + 1)
  + geom_vline(xintercept=this_year, lty=2)
  + scale_x_continuous(breaks=seq(2013,this_year,by=2))
  + geom_point()
##  + geom_smooth(method="lm",fullrange=TRUE,
  ##                formula = y ~ poly(x,2))
  + geom_smooth(method="gam",fullrange=TRUE,
                formula = y ~ s(x, bs = "tp", k=8))
  + geom_smooth(method="gam",fullrange=TRUE,
                formula = y ~ s(x, bs = "cs", k=8), color = "purple")
  + theme_bw()
)

print(gg0)

ggsave("nserc_dates.png")

## setup for crazy range of polynomial fits
yvec <- seq(2013, this_year,length=51)
predvals <- purrr::map_dfr(1:7,
                           ~data.frame(year=yvec,
                                       date=predict(lm(date~poly(as.numeric(year),.),data=df),
                                                    newdata=data.frame(year=yvec))),
                           .id="order") %>%
    mutate(across(date,as.Date,origin=as.Date("1970-01-01")))

gg1 <- gg0 + geom_line(data=predvals,aes(colour=factor(order)))

print(gg1)

ggsave("nserc_dates_poly.png")
predvals %>% filter(order %in% 1:2,year==2021)