Untitled

DATA DOUBLE CONFIRM

Covid-19 projections based on Curve Fitting using R

Based on a simplistic model of curve fitting, we are able to derive a projection that coincides with what was reported, "Singapore could see Covid-19 cases hit 5,000 a day in two weeks"[https://www.straitstimes.com/singapore/health/singapore-could-see-5000-daily-covid-19-cases-by-mid-oct-but-most-will-have-no-or].




R Code for Curve fitting using Loess regression:

data<-read.csv("moving-7-day-average-covid-19-singapore-QueryResult.csv",header=T) ##get the data from https://data.world/.../covid-19-singapore/workspace/query...
head(data)
library(ggplot2)
data2<-data[1:60,1:2]
data2
data2_ts <- as.ts(data2)
p<-ggplot(as.data.frame(data2_ts),aes(x=date,y=daily_confirmed))+
  geom_point()+
  geom_smooth(method="loess")
model <- loess(daily_confirmed~date,as.data.frame(data2_ts), control=loess.control(surface="direct"))
newdf <- data.frame(date=seq(61,74,1))
predictions <- predict(model, newdata=seq(61,74,1), se=TRUE)
newdf$fit <- predictions$fit
newdf$upper <- predictions$fit + qt(0.975,predictions$df)*predictions$se
newdf$lower <- predictions$fit - qt(0.975,predictions$df)*predictions$se
head(newdf)
p + 
  geom_ribbon(data=newdf, aes(x=date, y=fit, ymax=upper, ymin=lower)) + #, fill="grey90"
  geom_line(data=newdf, aes(x=date, y=fit), color='steelblue', lwd=1.2, lty=2)


Reference:

https://stackoverflow.com/questions/41917566/extrapolation-of-non-linear-relationships-in-r-ggplot2



I also tried fitting an exponential curve to the data points. This is a more aggressive model as you can see the projected number of daily confirmed cases gets close to 8000 in two weeks' time.


R code for Curve fitting using non-linear least squares:

library(easynls)
nlsfit<- nls(formula = daily_confirmed ~ exp(a+b*date), data = as.data.frame(data2_ts), start=list(a=25 ,b=0.05))
summary(nlsfit)
newdf <- data.frame(date=seq(61,74,1))
newdf

predictions <- predict(nlsfit, newdata=newdf, se.fit = TRUE)
predictions
newdf$fit<-predictions
head(newdf)
p + 
  geom_line(data=newdf, aes(x=date, y=fit), color='steelblue', lwd=1.2, lty=2) +
  labs(x = "Historical data (in days)", y = "Number of daily confirmed cases")



90 views