projection/prediction of NSERC Discovery award dates

nserc_dates.R

library(tidyverse)
library(png)
## https://stackoverflow.com/questions/9917049/inserting-an-image-to-ggplot2
## 2023 date is when McMaster's university office announced to recipients
##  (before ResearchNet posting, dates may vary by university)
this_year <- 2024
(df <- read.table(text="
2023 March 29
2022 April 11
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)))
)


if (!file.exists("nserc_logo.png")) {
    download.file("https://www.nserc-crsng.gc.ca/img/logos/img-logo2-en.png",
                  dest = "nserc_logo.png")
}
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")
  ## cheating a bit to get a Gaussian process that's fairly quickly mean-reverting
  ## m = c(-2, 4, 1.5) -> power-exponential with scale 4 and power 1.5, i.e.
  ##  correlation \propto (d/4)^(1.5)
  + geom_smooth(method = "gam", fullrange = TRUE,
              formula = y ~ s(x, bs = "gp", k=8, m=c(-2, 4, 1.5)), color = "red")
  + theme_bw()
)

ymin <- as.numeric(lubridate::ymd(paste(this_year, "mar", "20")))
ymax <- as.numeric(lubridate::ymd(paste(this_year, "mar", "23")))
logo <- readPNG("nserc_logo.png")
gg0B <- gg0 + annotation_raster(logo, xmin= 2019.5, xmax = 2021.5,
                                ymin = ymin, ymax = ymax)
                                
print(gg0B)

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)