The Process

I wanted to figure out a way to get a relative sense of the “severity” inherent in case numbers coming out in Alberta. As testing increases, cases are likely to increase as well. However, that doesn’t tell us much about how worried we should be about those increasing numbers.

I came across this paper that did just that and adapted the methodology to Alberta’s data.

In brief, this is how the process works. You take the number of cases, number of tests, and some measure of true severity, like ICU admissions, hospitalizations, or deaths. You then do a regression that determines how well those case numbers predict those severe outcomes. You then add in the testing data and see how much it improves the predictions. That allows you to calculate a “case multiplier”. Essentially you’re saying that not every case is created equally. A case when there is a 1% positivity rate is different than one when the case positivity rate is 6%.

That case multiplier allows you to multiply the case numbers to give a clearer picture of the true severity of the case numbers and how likely they might be to lead to severe outcomes.

Collecting the Data

Alberta’s data is kept here. Right click on the screen and select “View Page Source”. This will take you to the source code. From there, you can paste the data into R as below. Just find from the original page which figures contain the data you need and you can paste it from there.

#libraries preloaded;dplyr,ggplot2,lubridate,zoo,caret,tidyr,stringr
totaldates<-c("2020-03-04","2020-03-05","2020-03-06","2020-03-07","2020-03-08","2020-03-09","2020-03-10","2020-03-11","2020-03-12","2020-03-13","2020-03-14","2020-03-15","2020-03-16","2020-03-17","2020-03-18","2020-03-19","2020-03-20","2020-03-21","2020-03-22","2020-03-23","2020-03-24","2020-03-25","2020-03-26","2020-03-27","2020-03-28","2020-03-29","2020-03-30","2020-03-31","2020-04-01","2020-04-02","2020-04-03","2020-04-04","2020-04-05","2020-04-06","2020-04-07","2020-04-08","2020-04-09","2020-04-10","2020-04-11","2020-04-12","2020-04-13","2020-04-14","2020-04-15","2020-04-16","2020-04-17","2020-04-18","2020-04-19","2020-04-20","2020-04-21","2020-04-22","2020-04-23","2020-04-24","2020-04-25","2020-04-26","2020-04-27","2020-04-28","2020-04-29","2020-04-30","2020-05-01","2020-05-02","2020-05-03","2020-05-04","2020-05-05","2020-05-06","2020-05-07","2020-05-08","2020-05-09","2020-05-10","2020-05-11","2020-05-12","2020-05-13","2020-05-14","2020-05-15","2020-05-16","2020-05-17","2020-05-18","2020-05-19","2020-05-20","2020-05-21","2020-05-22","2020-05-23","2020-05-24","2020-05-25","2020-05-26","2020-05-27","2020-05-28","2020-05-29","2020-05-30","2020-05-31","2020-06-01","2020-06-02","2020-06-03","2020-06-04","2020-06-05","2020-06-06","2020-06-07","2020-06-08","2020-06-09","2020-06-10","2020-06-11","2020-06-12","2020-06-13","2020-06-14","2020-06-15","2020-06-16","2020-06-17","2020-06-18","2020-06-19","2020-06-20","2020-06-21","2020-06-22","2020-06-23","2020-06-24","2020-06-25","2020-06-26","2020-06-27","2020-06-28","2020-06-29","2020-06-30","2020-07-01","2020-07-02","2020-07-03","2020-07-04","2020-07-05","2020-07-06","2020-07-07","2020-07-08","2020-07-09","2020-07-10","2020-07-11","2020-07-12","2020-07-13","2020-07-14","2020-07-15","2020-07-16","2020-07-17","2020-07-18","2020-07-19","2020-07-20","2020-07-21","2020-07-22","2020-07-23","2020-07-24","2020-07-25","2020-07-26","2020-07-27","2020-07-28","2020-07-29","2020-07-30","2020-07-31","2020-08-01","2020-08-02","2020-08-03","2020-08-04","2020-08-05","2020-08-06","2020-08-07","2020-08-08","2020-08-09","2020-08-10","2020-08-11","2020-08-12","2020-08-13","2020-08-14","2020-08-15","2020-08-16","2020-08-17","2020-08-18","2020-08-19","2020-08-20","2020-08-21","2020-08-22","2020-08-23","2020-08-24","2020-08-25","2020-08-26","2020-08-27","2020-08-28","2020-08-29","2020-08-30","2020-08-31","2020-09-01","2020-09-02","2020-09-03","2020-09-04","2020-09-05","2020-09-06","2020-09-07","2020-09-08","2020-09-09","2020-09-10","2020-09-11","2020-09-12","2020-09-13","2020-09-14","2020-09-15","2020-09-16","2020-09-17","2020-09-18","2020-09-19","2020-09-20","2020-09-21","2020-09-22","2020-09-23","2020-09-24","2020-09-25","2020-09-26","2020-09-27","2020-09-28","2020-09-29","2020-09-30","2020-10-01","2020-10-02","2020-10-03","2020-10-04","2020-10-05","2020-10-06","2020-10-07","2020-10-08","2020-10-09","2020-10-10","2020-10-11","2020-10-12","2020-10-13","2020-10-14","2020-10-15")
totaldates<-ymd(totaldates)
totalcases<-c(0,0,1,1,1,7,16,24,26,34,53,62,89,100,132,165,209,243,282,332,399,455,502,587,633,660,699,832,939,1052,1108,1158,1202,1232,1281,1312,1351,1403,1455,1524,1592,1720,1849,1991,2204,2391,2589,2778,3049,3342,3693,3933,4162,4368,4548,4809,5045,5273,5406,5523,5593,5669,5732,5797,5878,5957,6041,6114,6162,6233,6296,6357,6428,6482,6528,6567,6612,6639,6669,6696,6729,6758,6771,6790,6817,6848,6878,6899,6936,6958,6978,6996,7018,7058,7081,7115,7140,7179,7227,7272,7299,7337,7390,7426,7472,7518,7565,7612,7644,7683,7721,7767,7794,7831,7899,7938,8006,8051,8085,8149,8207,8238,8287,8336,8383,8426,8469,8543,8609,8699,8778,8866,8951,9069,9170,9338,9442,9534,9667,9802,9911,10026,10145,10243,10333,10416,10548,10667,10792,10893,10961,11034,11098,11194,11255,11387,11503,11603,11651,11738,11854,11928,12012,12114,12199,12299,12385,12466,12568,12708,12798,12904,12974,13048,13175,13282,13438,13581,13767,13876,14030,14144,14274,14429,14598,14768,14904,15051,15149,15263,15381,15499,15669,15809,15933,16106,16252,16354,16470,16570,16692,16828,16966,17097,17243,17366,17545,17701,17855,18005,18161,18301,18422,18679,18889,19172,19295,19649,19963,20227,20483,20730,20953,21196,21445,21775)
#make dataframe in which to place everything
data<-data.frame(date=seq(ymd("2020-03-04"),ymd("2020-10-15"),by="day"))
data$cases<-totalcases[match(data$date,totaldates)]
#change total cases to incident cases
data$incident<-c(0,diff(data$cases))

deathdates<-c("2020-03-04","2020-03-05","2020-03-06","2020-03-07","2020-03-08","2020-03-09","2020-03-10","2020-03-11","2020-03-12","2020-03-13","2020-03-14","2020-03-15","2020-03-16","2020-03-17","2020-03-18","2020-03-19","2020-03-20","2020-03-21","2020-03-22","2020-03-23","2020-03-24","2020-03-25","2020-03-26","2020-03-27","2020-03-28","2020-03-29","2020-03-30","2020-03-31","2020-04-01","2020-04-02","2020-04-03","2020-04-04","2020-04-05","2020-04-06","2020-04-07","2020-04-08","2020-04-09","2020-04-10","2020-04-11","2020-04-12","2020-04-13","2020-04-14","2020-04-15","2020-04-16","2020-04-17","2020-04-18","2020-04-19","2020-04-20","2020-04-21","2020-04-22","2020-04-23","2020-04-24","2020-04-25","2020-04-26","2020-04-27","2020-04-28","2020-04-29","2020-04-30","2020-05-01","2020-05-02","2020-05-03","2020-05-04","2020-05-05","2020-05-06","2020-05-07","2020-05-08","2020-05-09","2020-05-10","2020-05-11","2020-05-12","2020-05-13","2020-05-14","2020-05-15","2020-05-16","2020-05-17","2020-05-18","2020-05-19","2020-05-20","2020-05-21","2020-05-22","2020-05-23","2020-05-24","2020-05-25","2020-05-26","2020-05-27","2020-05-28","2020-05-29","2020-05-30","2020-05-31","2020-06-01","2020-06-02","2020-06-03","2020-06-04","2020-06-05","2020-06-06","2020-06-07","2020-06-08","2020-06-09","2020-06-10","2020-06-11","2020-06-12","2020-06-13","2020-06-14","2020-06-15","2020-06-16","2020-06-17","2020-06-18","2020-06-19","2020-06-20","2020-06-21","2020-06-22","2020-06-23","2020-06-24","2020-06-25","2020-06-26","2020-06-27","2020-06-28","2020-06-29","2020-06-30","2020-07-01","2020-07-02","2020-07-03","2020-07-04","2020-07-05","2020-07-06","2020-07-07","2020-07-08","2020-07-09","2020-07-10","2020-07-11","2020-07-12","2020-07-13","2020-07-14","2020-07-15","2020-07-16","2020-07-17","2020-07-18","2020-07-19","2020-07-20","2020-07-21","2020-07-22","2020-07-23","2020-07-24","2020-07-25","2020-07-26","2020-07-27","2020-07-28","2020-07-29","2020-07-30","2020-07-31","2020-08-01","2020-08-02","2020-08-03","2020-08-04","2020-08-05","2020-08-06","2020-08-07","2020-08-08","2020-08-09","2020-08-10","2020-08-11","2020-08-12","2020-08-13","2020-08-14","2020-08-15","2020-08-16","2020-08-17","2020-08-18","2020-08-19","2020-08-20","2020-08-21","2020-08-22","2020-08-23","2020-08-24","2020-08-25","2020-08-26","2020-08-27","2020-08-28","2020-08-29","2020-08-30","2020-08-31","2020-09-01","2020-09-02","2020-09-03","2020-09-04","2020-09-05","2020-09-06","2020-09-07","2020-09-08","2020-09-09","2020-09-10","2020-09-11","2020-09-12","2020-09-13","2020-09-14","2020-09-15","2020-09-16","2020-09-17","2020-09-18","2020-09-19","2020-09-20","2020-09-21","2020-09-22","2020-09-23","2020-09-24","2020-09-25","2020-09-26","2020-09-27","2020-09-28","2020-09-29","2020-09-30","2020-10-01","2020-10-02","2020-10-03","2020-10-04","2020-10-05","2020-10-06","2020-10-07","2020-10-08","2020-10-09","2020-10-10","2020-10-11","2020-10-12","2020-10-13","2020-10-14","2020-10-15")
deathdates<-ymd(deathdates)
deaths<-c(0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,5,10,11,12,15,18,23,25,28,28,32,36,40,45,45,48,48,50,50,54,57,62,66,72,75,80,80,84,88,90,94,96,100,102,104,106,107,111,112,115,115,117,118,121,124,124,125,126,128,129,131,132,136,138,138,139,139,141,143,143,143,144,144,144,145,146,147,147,148,150,150,151,151,151,151,151,151,151,151,151,152,152,152,152,153,153,153,153,154,154,154,154,154,155,155,155,155,156,156,156,158,159,162,162,162,162,163,166,166,167,167,170,171,173,175,177,179,182,184,187,190,194,195,196,200,200,200,203,204,207,209,209,214,216,218,220,222,222,222,225,226,227,228,229,229,231,232,236,236,236,237,237,237,237,238,239,240,240,241,242,244,245,249,250,250,251,252,252,252,252,252,252,253,253,254,255,257,259,261,261,262,263,264,264,265,269,272,276,278,279,279,281,283,284,285,286,287,287,288,288,288)
data$deaths<-deaths[match(data$date,deathdates)]
data$deaths<-c(0,diff(data$deaths))

icudates<-c("2020-03-08","2020-03-09","2020-03-10","2020-03-11","2020-03-12","2020-03-13","2020-03-14","2020-03-15","2020-03-16","2020-03-17","2020-03-18","2020-03-19","2020-03-20","2020-03-21","2020-03-22","2020-03-23","2020-03-24","2020-03-25","2020-03-26","2020-03-27","2020-03-28","2020-03-29","2020-03-30","2020-03-31","2020-04-01","2020-04-02","2020-04-03","2020-04-04","2020-04-05","2020-04-06","2020-04-07","2020-04-08","2020-04-09","2020-04-10","2020-04-11","2020-04-12","2020-04-13","2020-04-14","2020-04-15","2020-04-16","2020-04-17","2020-04-18","2020-04-19","2020-04-20","2020-04-21","2020-04-22","2020-04-23","2020-04-24","2020-04-25","2020-04-26","2020-04-27","2020-04-28","2020-04-29","2020-04-30","2020-05-01","2020-05-02","2020-05-03","2020-05-04","2020-05-05","2020-05-06","2020-05-07","2020-05-08","2020-05-09","2020-05-10","2020-05-11","2020-05-12","2020-05-13","2020-05-14","2020-05-15","2020-05-16","2020-05-17","2020-05-18","2020-05-19","2020-05-20","2020-05-21","2020-05-22","2020-05-23","2020-05-24","2020-05-25","2020-05-26","2020-05-27","2020-05-28","2020-05-29","2020-05-30","2020-05-31","2020-06-01","2020-06-02","2020-06-03","2020-06-04","2020-06-05","2020-06-06","2020-06-07","2020-06-08","2020-06-09","2020-06-10","2020-06-11","2020-06-12","2020-06-13","2020-06-14","2020-06-15","2020-06-16","2020-06-17","2020-06-18","2020-06-19","2020-06-20","2020-06-21","2020-06-22","2020-06-23","2020-06-24","2020-06-25","2020-06-26","2020-06-27","2020-06-28","2020-06-29","2020-06-30","2020-07-01","2020-07-02","2020-07-03","2020-07-04","2020-07-05","2020-07-06","2020-07-07","2020-07-08","2020-07-09","2020-07-10","2020-07-11","2020-07-12","2020-07-13","2020-07-14","2020-07-15","2020-07-16","2020-07-17","2020-07-18","2020-07-19","2020-07-20","2020-07-21","2020-07-22","2020-07-23","2020-07-24","2020-07-25","2020-07-26","2020-07-27","2020-07-28","2020-07-29","2020-07-30","2020-07-31","2020-08-01","2020-08-02","2020-08-03","2020-08-04","2020-08-05","2020-08-06","2020-08-07","2020-08-08","2020-08-09","2020-08-10","2020-08-11","2020-08-12","2020-08-13","2020-08-14","2020-08-15","2020-08-16","2020-08-17","2020-08-18","2020-08-19","2020-08-20","2020-08-21","2020-08-22","2020-08-23","2020-08-24","2020-08-25","2020-08-26","2020-08-27","2020-08-28","2020-08-29","2020-08-30","2020-08-31","2020-09-01","2020-09-02","2020-09-03","2020-09-04","2020-09-05","2020-09-06","2020-09-07","2020-09-08","2020-09-09","2020-09-10","2020-09-11","2020-09-12","2020-09-13","2020-09-14","2020-09-15","2020-09-16","2020-09-17","2020-09-18","2020-09-19","2020-09-20","2020-09-21","2020-09-22","2020-09-23","2020-09-24","2020-09-25","2020-09-26","2020-09-27","2020-09-28","2020-09-29","2020-09-30","2020-10-01","2020-10-02","2020-10-03","2020-10-04","2020-10-05","2020-10-06","2020-10-07","2020-10-08","2020-10-09","2020-10-10","2020-10-11","2020-10-12","2020-10-13","2020-10-14","2020-10-15")
icudates<-ymd(icudates)
icu<-c(0,0,0,0,1,2,2,2,2,3,3,8,9,10,10,10,11,11,11,13,14,15,17,18,20,20,19,20,20,18,16,16,15,15,15,15,14,15,12,13,14,16,19,18,20,19,18,21,19,20,19,22,21,21,22,18,20,20,20,19,18,16,14,12,11,11,9,9,9,8,9,9,8,7,6,6,7,6,5,5,4,4,5,6,6,6,6,6,5,5,5,5,5,5,4,4,5,5,6,6,7,7,6,6,7,6,6,7,8,8,8,8,9,9,8,8,9,8,7,6,6,7,7,9,8,11,13,13,7,8,15,14,12,14,13,15,18,17,14,14,15,13,14,14,13,14,16,16,21,21,19,18,17,17,15,16,15,14,14,13,13,11,13,14,13,11,12,10,10,8,8,8,8,9,9,11,11,10,10,11,13,13,11,10,7,7,6,6,7,7,9,8,8,8,9,11,12,12,13,15,15,16,16,14,12,12,13,15,16,16,14,16,15,13,11,12,13,15,13,14,16,11)
data$icu<-icu[match(data$date,icudates)]
data$icu<-ifelse(is.na(data$icu),0,data$icu)

hospdates<-c("2020-03-08","2020-03-09","2020-03-10","2020-03-11","2020-03-12","2020-03-13","2020-03-14","2020-03-15","2020-03-16","2020-03-17","2020-03-18","2020-03-19","2020-03-20","2020-03-21","2020-03-22","2020-03-23","2020-03-24","2020-03-25","2020-03-26","2020-03-27","2020-03-28","2020-03-29","2020-03-30","2020-03-31","2020-04-01","2020-04-02","2020-04-03","2020-04-04","2020-04-05","2020-04-06","2020-04-07","2020-04-08","2020-04-09","2020-04-10","2020-04-11","2020-04-12","2020-04-13","2020-04-14","2020-04-15","2020-04-16","2020-04-17","2020-04-18","2020-04-19","2020-04-20","2020-04-21","2020-04-22","2020-04-23","2020-04-24","2020-04-25","2020-04-26","2020-04-27","2020-04-28","2020-04-29","2020-04-30","2020-05-01","2020-05-02","2020-05-03","2020-05-04","2020-05-05","2020-05-06","2020-05-07","2020-05-08","2020-05-09","2020-05-10","2020-05-11","2020-05-12","2020-05-13","2020-05-14","2020-05-15","2020-05-16","2020-05-17","2020-05-18","2020-05-19","2020-05-20","2020-05-21","2020-05-22","2020-05-23","2020-05-24","2020-05-25","2020-05-26","2020-05-27","2020-05-28","2020-05-29","2020-05-30","2020-05-31","2020-06-01","2020-06-02","2020-06-03","2020-06-04","2020-06-05","2020-06-06","2020-06-07","2020-06-08","2020-06-09","2020-06-10","2020-06-11","2020-06-12","2020-06-13","2020-06-14","2020-06-15","2020-06-16","2020-06-17","2020-06-18","2020-06-19","2020-06-20","2020-06-21","2020-06-22","2020-06-23","2020-06-24","2020-06-25","2020-06-26","2020-06-27","2020-06-28","2020-06-29","2020-06-30","2020-07-01","2020-07-02","2020-07-03","2020-07-04","2020-07-05","2020-07-06","2020-07-07","2020-07-08","2020-07-09","2020-07-10","2020-07-11","2020-07-12","2020-07-13","2020-07-14","2020-07-15","2020-07-16","2020-07-17","2020-07-18","2020-07-19","2020-07-20","2020-07-21","2020-07-22","2020-07-23","2020-07-24","2020-07-25","2020-07-26","2020-07-27","2020-07-28","2020-07-29","2020-07-30","2020-07-31","2020-08-01","2020-08-02","2020-08-03","2020-08-04","2020-08-05","2020-08-06","2020-08-07","2020-08-08","2020-08-09","2020-08-10","2020-08-11","2020-08-12","2020-08-13","2020-08-14","2020-08-15","2020-08-16","2020-08-17","2020-08-18","2020-08-19","2020-08-20","2020-08-21","2020-08-22","2020-08-23","2020-08-24","2020-08-25","2020-08-26","2020-08-27","2020-08-28","2020-08-29","2020-08-30","2020-08-31","2020-09-01","2020-09-02","2020-09-03","2020-09-04","2020-09-05","2020-09-06","2020-09-07","2020-09-08","2020-09-09","2020-09-10","2020-09-11","2020-09-12","2020-09-13","2020-09-14","2020-09-15","2020-09-16","2020-09-17","2020-09-18","2020-09-19","2020-09-20","2020-09-21","2020-09-22","2020-09-23","2020-09-24","2020-09-25","2020-09-26","2020-09-27","2020-09-28","2020-09-29","2020-09-30","2020-10-01","2020-10-02","2020-10-03","2020-10-04","2020-10-05","2020-10-06","2020-10-07","2020-10-08","2020-10-09","2020-10-10","2020-10-11","2020-10-12","2020-10-13","2020-10-14","2020-10-15")
hospdates<-ymd(hospdates)
hosp<-c(0,1,1,1,1,3,3,3,4,4,9,7,7,9,10,12,18,22,22,21,23,25,25,24,21,23,26,27,24,27,30,33,35,37,36,35,35,33,42,45,49,40,43,44,41,45,47,49,51,55,58,56,64,67,59,65,63,62,64,60,60,56,49,52,52,53,51,47,42,40,40,40,35,36,36,32,28,27,28,28,27,28,27,20,18,18,19,14,14,13,13,15,14,11,11,11,14,12,13,17,20,20,23,23,20,22,20,21,19,22,24,24,23,23,24,22,24,30,39,40,41,40,34,32,34,32,32,42,53,56,53,61,62,61,71,76,75,72,74,65,65,67,63,64,63,62,56,57,52,45,44,38,38,38,38,35,35,37,35,35,36,39,40,38,36,32,34,36,37,39,42,44,42,37,34,37,39,42,38,38,38,37,37,38,43,40,39,40,38,36,40,38,39,43,49,47,50,50,50,51,54,55,53,58,58,57,59,55,56,58,59,60,71,78,80,79,84,84,89,91,94,106)
data$hosp<-hosp[match(data$date,hospdates)]
data$hosp<-ifelse(is.na(data$hosp),0,data$hosp)

testdates<-c("2020-01-04","2020-01-20","2020-01-21","2020-01-23","2020-01-24","2020-01-25","2020-01-26","2020-01-27","2020-01-28","2020-01-30","2020-01-31","2020-02-01","2020-02-03","2020-02-05","2020-02-06","2020-02-07","2020-02-09","2020-02-10","2020-02-11","2020-02-12","2020-02-13","2020-02-14","2020-02-15","2020-02-16","2020-02-17","2020-02-18","2020-02-19","2020-02-20","2020-02-21","2020-02-22","2020-02-23","2020-02-24","2020-02-25","2020-02-26","2020-02-27","2020-02-28","2020-02-29","2020-03-01","2020-03-02","2020-03-03","2020-03-04","2020-03-05","2020-03-06","2020-03-07","2020-03-08","2020-03-09","2020-03-10","2020-03-11","2020-03-12","2020-03-13","2020-03-14","2020-03-15","2020-03-16","2020-03-17","2020-03-18","2020-03-19","2020-03-20","2020-03-21","2020-03-22","2020-03-23","2020-03-24","2020-03-25","2020-03-26","2020-03-27","2020-03-28","2020-03-29","2020-03-30","2020-03-31","2020-04-01","2020-04-02","2020-04-03","2020-04-04","2020-04-05","2020-04-06","2020-04-07","2020-04-08","2020-04-09","2020-04-10","2020-04-11","2020-04-12","2020-04-13","2020-04-14","2020-04-15","2020-04-16","2020-04-17","2020-04-18","2020-04-19","2020-04-20","2020-04-21","2020-04-22","2020-04-23","2020-04-24","2020-04-25","2020-04-26","2020-04-27","2020-04-28","2020-04-29","2020-04-30","2020-05-01","2020-05-02","2020-05-03","2020-05-04","2020-05-05","2020-05-06","2020-05-07","2020-05-08","2020-05-09","2020-05-10","2020-05-11","2020-05-12","2020-05-13","2020-05-14","2020-05-15","2020-05-16","2020-05-17","2020-05-18","2020-05-19","2020-05-20","2020-05-21","2020-05-22","2020-05-23","2020-05-24","2020-05-25","2020-05-26","2020-05-27","2020-05-28","2020-05-29","2020-05-30","2020-05-31","2020-06-01","2020-06-02","2020-06-03","2020-06-04","2020-06-05","2020-06-06","2020-06-07","2020-06-08","2020-06-09","2020-06-10","2020-06-11","2020-06-12","2020-06-13","2020-06-14","2020-06-15","2020-06-16","2020-06-17","2020-06-18","2020-06-19","2020-06-20","2020-06-21","2020-06-22","2020-06-23","2020-06-24","2020-06-25","2020-06-26","2020-06-27","2020-06-28","2020-06-29","2020-06-30","2020-07-01","2020-07-02","2020-07-03","2020-07-04","2020-07-05","2020-07-06","2020-07-07","2020-07-08","2020-07-09","2020-07-10","2020-07-11","2020-07-12","2020-07-13","2020-07-14","2020-07-15","2020-07-16","2020-07-17","2020-07-18","2020-07-19","2020-07-20","2020-07-21","2020-07-22","2020-07-23","2020-07-24","2020-07-25","2020-07-26","2020-07-27","2020-07-28","2020-07-29","2020-07-30","2020-07-31","2020-08-01","2020-08-02","2020-08-03","2020-08-04","2020-08-05","2020-08-06","2020-08-07","2020-08-08","2020-08-09","2020-08-10","2020-08-11","2020-08-12","2020-08-13","2020-08-14","2020-08-15","2020-08-16","2020-08-17","2020-08-18","2020-08-19","2020-08-20","2020-08-21","2020-08-22","2020-08-23","2020-08-24","2020-08-25","2020-08-26","2020-08-27","2020-08-28","2020-08-29","2020-08-30","2020-08-31","2020-09-01","2020-09-02","2020-09-03","2020-09-04","2020-09-05","2020-09-06","2020-09-07","2020-09-08","2020-09-09","2020-09-10","2020-09-11","2020-09-12","2020-09-13","2020-09-14","2020-09-15","2020-09-16","2020-09-17","2020-09-18","2020-09-19","2020-09-20","2020-09-21","2020-09-22","2020-09-23","2020-09-24","2020-09-25","2020-09-26","2020-09-27","2020-09-28","2020-09-29","2020-09-30","2020-10-01","2020-10-02","2020-10-03","2020-10-04","2020-10-05","2020-10-06","2020-10-07","2020-10-08","2020-10-09","2020-10-10","2020-10-11","2020-10-12","2020-10-13","2020-10-14","2020-10-15")
testdates<-ymd(testdates)
tests<-c(1,1,1,3,4,1,1,3,1,4,3,3,1,2,2,1,12,3,13,10,8,10,3,6,7,5,4,5,3,6,2,2,14,16,14,20,32,25,25,38,69,56,57,276,439,628,763,1311,1116,1547,1511,1797,1445,2037,2797,2810,3505,3429,2795,2680,3067,1590,1240,3575,2074,1849,2476,4616,3496,3834,1583,1686,1077,846,1550,1161,2121,2614,2102,2147,1986,2375,2864,2757,4998,3554,4061,3768,4004,3738,4131,4169,4281,3942,3111,3873,4598,4563,2507,4432,2881,2214,2606,2520,3594,3300,3592,2826,2429,3207,3528,3953,3845,3404,2651,2789,2045,2676,3137,3120,3246,2733,2509,2526,2759,3089,3072,2812,2717,2358,3476,4096,4718,4855,5018,4759,4401,5099,5859,7297,5162,6496,6352,5407,5890,6675,7771,6363,6707,5657,5495,5558,5209,5495,5146,5366,5624,6012,5439,6167,5448,4704,4301,4423,4776,4746,5362,5969,5748,7531,5939,4443,4471,5843,4696,7196,4994,5152,5773,5789,5999,6417,7785,7218,5574,5845,6303,6122,5846,8130,6366,5015,5253,5029,5629,5869,6051,6891,5139,5019,5566,5370,5502,7240,5855,6081,5728,6312,6607,6914,7146,6888,5934,5790,6212,6913,7709,6835,7914,8535,6555,5594,6224,7341,7680,7517,8251,8681,6986,6438,8138,8307,12743,9471,8577,8228,8407,7305,8344,6603,8560,9446,7883,8355,9526,10651,10710,12369,10541,9053,9162,8258,7942,11097,9849,10970,7794,9832,14732,9539,8062,9886,6581,8651,7168,7873)
data$tests<-tests[match(data$date,testdates)]

Smoothing the Data

Now that the data is in a dataframe, it is best to smooth it to 7 day rolling sums. This is because tests and cases are heavily weekday dependent. There is too much fluctuation day to day to get strong patterns in a regression. So it is best to smooth it out first. Everything will be smoothed to a 7 day sum instead of average. It doesn’t really matter, but it just makes more sense to me.

data$cases<-data$incident
data$incident<-NULL
data$cases<-rollsum(data$cases,k=7,fill=NA,align="right")
data$deaths<-rollsum(data$deaths,k=7,fill=NA,align="right")
data$icu<-rollsum(data$icu,k=7,fill=NA,align="right")
data$hosp<-rollsum(data$hosp,k=7,fill=NA,align="right")
data$tests<-rollsum(data$tests,k=7,fill=NA,align="right")

Now you can calculate the case positive rate and get rid of the NA entries.

data$pos_rate<-round(data$cases/data$tests*100,2)
data<-data[complete.cases(data),]

Generally, severe outcomes will tend to lag case numbers at least a little bit, so we can create different lags in order to test which ones tend to be most closely predicted by case numbers. Since there have been relatively few deaths in Alberta, I won’t use that as a severe outcome. ICU patient-days are a good indicator of not only severity of illness in the population, but also the potential for COVID to overwhelm our healthcare capacity.

Also, I want to use a training data set so as not to overfit the model.

#figure out most predictive lag; 5 days is the most predictive in this case
data$icu5<-lead(data$icu,5)
data<-data[complete.cases(data),]
index<-createDataPartition(data$icu5,p=0.75,list=F)
train<-data[index,]
ctrl<-trainControl(method="repeatedcv",number=10,repeats=10)
#predict just with cases
lm<-train(icu5~cases,data=train,trControl=ctrl,method="lm")

#create new regression variable with cases multiplied by positive rate
train$case.pos<-train$cases*train$pos_rate
lm<-train(icu5~cases+case.pos,data=train,trControl=ctrl,method="lm")

From the output of the regression you see that the case.pos variable has a coefficient of 0.00383 and the cases 0.032406. To get the adjustment variable you take case.pos coefficient and divide it by the cases coefficient.

adj<-0.003830/0.032406

That allows you to then calculate the case multiplier as per the paper linked above.

data$case_mult<-1+(adj*data$pos_rate)
data$adj_cases<-data$case_mult*data$cases

Now you can plot the actual and adjusted cases.

plot<-data%>%dplyr::select(date,cases,adj_cases)%>%gather(type,value,cases:adj_cases)
plot$type<-c(rep("Actual Cases",215),rep("Adjusted Cases",215))

plot$time<-rep(1:215,2)
plot$date_lab<-paste(month.abb[month(plot$date)],day(plot$date),sep="-")
seq<-seq(1,215,by=14)

Now create the plot.

And voila! You have a plot showing the relative cases adjusted for positive test rates and more indicative of the potentially severe outcomes from reported cases.