-
Notifications
You must be signed in to change notification settings - Fork 0
/
covidHierV48rf_Github_counterfactuals.R
1699 lines (1413 loc) · 91.5 KB
/
covidHierV48rf_Github_counterfactuals.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
# SIMULATION
# Script runs simulations for counterfactuals for 10 March 2020 to 7 February 2021 (varying response framework thresholds and time frames)
# Copyright (C) 2021 Skye SG Chen, Kathyrn R Fair, Vadim A Karatayev
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <https://www.gnu.org/licenses/>.
# Dependencies
library(abind);
library(plyr);
library(dplyr);
library(data.table);
library(EpiEstim);
# Suppress summarize info
options(dplyr.summarise.inform = FALSE)
# Directory variables
input_dir = "InputFiles" # Directory where all the input files are stored
output_dir = "OutputFiles/FCF" # Directory to store output files
dir.create(output_dir, showWarnings = FALSE, recursive = TRUE) # Creates output directory if it doesn't exist
#Read in all necessary data for fitting
cmat=readRDS(sprintf("%s/cmat_data_weighted.rds", input_dir)); #Contact matrix data from Prem et al. (2020)
DATA=readRDS(sprintf("%s/covidHierData.rds", input_dir)); #See readme file for description of contents
omgdat<-readRDS(sprintf("%s/mobilitydat_REAL_to2021-02-27_V4.rds", input_dir)) #read in mobility data
regiondat=readRDS(sprintf("%s/ONdat_casesbyPHU_to2021-08-10.rds", input_dir)); ### Contains new region specific known case data for fitting
agedat=readRDS(sprintf("%s/ONdat_newKage_to2021-08-10.rds", input_dir)); ### Contains new age specific known case data for fitting
regionid=readRDS(sprintf("%s/PHUtoREGIONlinker_numeric.rds", input_dir)); #COntains data for linking census divisions to their associated PHU
rfdat = readRDS(sprintf("%s/response_framework_refined_2021-05-01.rds", input_dir)) # read in response framework data
testing_volumes=readRDS(sprintf("%s/tests_by_PHU_aug112021.rds", input_dir)) # Read in testing volumes by PHU data
# Refine the data
agedat$tot<-cumsum(rowSums(agedat[,3:7])) #Add column of total new cases across all ages
regiondat$tot<-cumsum(rowSums(regiondat[,2:35])) #Add column of total new cases across all regions
testing_volumes$ts50 = as.numeric(testing_volumes$Date - as.Date("2020-03-10")) #Add column for ts50, days since the start of the epidemic
#Drop all dates where totals are impacted by reporting lags
end_date<-"2021-04-30"
agedat<-agedat[agedat$Date<=end_date,]
regiondat<-regiondat[regiondat$Date<=end_date,]
rfdat<-rfdat[rfdat$Date<=end_date,]
tstart<-Sys.time()
#Set code version
codeversion<-"v48rf"
###vvvvvvvvvvvvvvvvvvvvvvvvvvvvvv Control panel vvvvvvvvvvvvvvvvvvvvvvvvvvvvvv###
### These variables controls which aspects of the simulation we want active
# When running the script on a supercomputer, turn this variable on! Disables messages and outputs used for debugging that aren't necessary for the supercomputer to have
supercomputer_mode = TRUE
debug_mode = FALSE
### Artifact of previous code, do not modify!
# cftype: Set closure counterfactual type i.e. schools remain open ("schoolopen"), workplaces remain open ("workopen"), both remain open ("bothopen") or both are shut ("neitheropen", corresponds to what actually occured in the province)
# reopeningtype: Set reopening type; with ("restricted") or without ("unrestricted") NPIs in schools/workplaces
# vdtype: Set individual NPI adherence counterfactual type i.e. no individual adherence to NPIs ("vdOFF") or individual adherence to NPIs in response to case numbers ("vdON")
cftype<-"neitheropen";
reopeningtype<-"restricted";
vdtype<-"vdON";
# Testing and debugging variables
printing_timestep = 20 # Print the current day in the simulation if it's a multiple of this int
tepi_message = FALSE # Prints tepi messages
disable_response_framework<-FALSE # Controls whether or not the response framework is active
init_s_vec <- c(0,30,60,90,300) # Vector containing initial shutdown lengths (DEPRECATED, but do not remove as parts of the code require this.)
indicators_active = c( # Controls which indicators are active. Comment out the indicators you want inactive
"" # Placeholder, keep "" uncommented
, "wir" # 2 (Weekly Incidence Rate)
, "ppos" # 3 (Percent Positivity)
, "Rt" # 4 (Effective Reproduction Number)
)
# Note: The simulation is designed to only calculate indicator values on days when a decision to update the response framework is required!
# This is hard coded in to increase time efficiency of the sim, but you can change when the response framework is activated by modifying rf_start and rf_end.
#### Counterfactual scenarios
zone_change_backup_func = median # The function to use when there is no unique mode from the three indicators. (default: median minimizes the error between data and sim)
# # Varying thresholds
# mu_vec = c(.1, .5, 1, 2) # Controls the strictness of the thresholds for each indicator. (Default value = 1)
# rf_start_vec = c(241,241,241,241); #Day that the response framework system got implemented (Default value = 241 representing Nov 7, 2020).
# rf_end_vec = c(290,290,290,290); # Day that we're suspending the response framework (Default value = 290 due to provincial shutdown on Dec 26th).
# my_length_vec <- c(425,425,425,425); # Number of days to run the simulation for (Default value = 375)
# Varying time frame
mu_vec = c(1,1,1,1,1) # Controls the strictness of the thresholds for each indicator. (Default value = 1)
rf_start_vec = c(241,211,79+14,241,241); #Day that the response framework system got implemented (Default value = 241 representing Nov 7, 2020).
rf_end_vec = c(290,290,290,320,400); # Day that we're suspending the response framework (Default value = 290 due to provincial shutdown on Dec 26th).
my_length_vec <- c(425,425,425,425,425); # Number of days to run the simulation for (Default value = 375)
# # Default only
# mu_vec = c(1) # Controls the strictness of the thresholds for each indicator. (Default value = 1)
# rf_start_vec = c(241); #Day that the response framework system got implemented (Default value = 241 representing Nov 7, 2020).
# rf_end_vec = c(290); # Day that we're suspending the response framework (Default value = 290 due to provincial shutdown on Dec 26th).
# my_length_vec <- c(375); # Number of days to run the simulation for (Default value = 375)
###^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Control panel ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^###
N_scene = length(mu_vec)
for (n in 1:N_scene){ # For running N_scene different counterfactual scenarios
# For loading variables representing the different scenarios
mu = mu_vec[n]
rf_start = rf_start_vec[n]
rf_end = rf_end_vec[n]
my_length = my_length_vec[n]
# Display which scenario we're running
# message("mu = ", mu, "\n")
message("rf_start = ", rf_start, "\n")
message("rf_end = ", rf_end, "\n")
# Name the experiment
# exp_name = sprintf("_thresholds=%s", mu) # For varying indicators
exp_name = sprintf("_rf(start,end)=(%s,%s)", rf_start, rf_end) # For varying response framework start and end dates
print(exp_name)
# ### For differing initial shutdown periods (DEPRECATED, do not remove, parts of the code require this)
init_shutdown <- init_s_vec[1] # Initial shutdown length
# cat("Initial Shutdown Length:", init_shutdown, "\n")
# exp_name<-paste(init_shutdown, "_shutdown", "_", my_length, "days", sep = "");
#Read in data on best parameter sets from fitting
#Select how many of the top fits you want (i.e. topnum<-10 indicates you want the 10 best parameter sets)
topnum <- 10
fitparms00 = readRDS(sprintf("%s/simsFITPARMS_%s.rds", input_dir, codeversion));
bestcutoff <- if(length(unique(fitparms00$LL))>(topnum+1)) {dplyr::nth(sort(unique(fitparms00$LL)), topnum+1)} else {1e8}
fitparms0 <- fitparms00[fitparms00$LL<bestcutoff,]
#Get rid of any dup parm sets (ID by LL)
checker<-fitparms0[!duplicated(fitparms0[ , "LL" ] ), ]
fitparms<- fitparms0[fitparms0$fit %in% checker$fit,]
parms_len = dim(fitparms)[2] - 2
goodfits<-1; # Do NOT modify this number, it should always be 1 at this point in the code!
for (fit in 1:topnum) {
parms=as.matrix(fitparms[fitparms$fit==unique(fitparms$fit)[fit],1:parms_len]); # use best fit from fitting
###vvvvvvvvvvvvvv Copy and paste simulation code here!!! vvvvvvvvvvvvvv###
#Some parameter name differences from paper:
#initial testing tauI_t0=cvTl, final testing tauI_tf=tauI, tauA=tauEAf*tauI
# a1,a2,a3,a4,a5 are age-specific susceptibility modifiers (gamma_i, i=1,2,3,4,5 in the paper)
# boost is L0 (impact of stay at home orders on NPI adherence)
#Mfact scales how much travel happens compared to reality; Mfact=1 is just movement from commuting data
#epsP allows individual NPI adherence efficacy to differ from that of closures (epsP=eps in paper)
#Tg and Tl are the gobal and local closure thresholds, n0 is fraction initially infected
#Msave is the travel matrix. Here Msave entries are numbers of commuters; msim3 converts them to proportions
pops=colSums(DATA$Msave)
###Adjust to 2020 Q4 pop estimate (from https://www150.statcan.gc.ca/t1/tbl1/en/tv.action?pid=1710000901), as region pop estimates are from 2016 census
pop2020<-14733119
popratio<-pop2020/sum(pops)
popadj2020=round(popratio*pops)
# # Parms array for fitting. Comment out for simulation! Uncomment for fitting!
# # Remember to update the simulation parms array if it's modified here!
# parms_initialized = TRUE
# if(debug_mode){
# warning("
# Comment out the hardcoded parms array definition.
# This is for initializing the fitting code.
# Use the fitted parameters instead!")}
# # Note: some parameters named here are artefacts of a previous version of the model. They are retained here to avoid breaking analysis code which requires input files to have a specific dimension but do not impact simulations
# parms=cbind(N=popadj2020,Mfact=popratio*2,s=0.2,Tg_w=1,Tl_w=exp(-9.14),Tg_s=1,Tl_s=exp(-9.14),
# xi_a = xi_a, xi_b = xi_b, xi_c = xi_c,
# # beta=BetaMod(rep(1,34))*exp(0)/mean(popadj2020), # original
# beta=BetaMod(xi_coefs)*exp(0)/mean(popadj2020),
# eps_w=eps_w, eps_s=eps_s,eps_h=eps_h,eps_o=eps_o,omg=exp(9.5),r=0.19,eta=0.8,alpha=0.4,sig=0.4,rho=0.67,n0=0.0001,
# atravel=0.5, a1=1,a2=1.75,a3=1,a4=5,a5=35, reopen_w=0.5, reopen_s=0.2, B=0.3, phi=80, zeta=0.025,
# tau0=0.035, psi1=0.025, psi2=0.025, psi3=0.025, psi4=0.025, psi5=0.1, kappa=0.3, taumax=0.5, boost=0.5,
# alpha_w1 = alpha_w1, alpha_w2 = alpha_w2, alpha_w3 = alpha_w3, alpha_w4 = alpha_w4,
# alpha_s1 = alpha_s1, alpha_s2 = alpha_s2, alpha_s3 = alpha_s3, alpha_s4 = alpha_s4,
# alpha_h1 = alpha_h1, alpha_h2 = alpha_h2, alpha_h3 = alpha_h3, alpha_h4 = alpha_h4,
# alpha_o1 = alpha_o1, alpha_o2 = alpha_o2, alpha_o3 = alpha_o3, alpha_o4 = alpha_o4,
# DATA$Msave[-50,]);
# Specification of closure/reopening events
inCstart=50; #all events occur at a distance from the day total cases >=50 (March 10th)
inClen_w1=79; #Duration of initial provincial workplace closure (March 25-June 11, Phase 2 commenced June 12)
inClen_s1=178; #Duration of initial provincial school closure (Mar 14 - Sept 7, Schools reopen Sept 8)
inClen_w2=46; #Duration of second provincial workplace closure, to first part of staggered reopening (Dec 26th 2020 - Feb 9th 2021)
inClen_s2=51; #Duration of second provincial school closure, to first part of staggered reopening (Dec 21st 2020 - Feb 9th 2021)
inBlen_s=70; #Duration of Summer break (June 30th - Sept 8th)
workstaggergap1<-6; #Gap for first 3 reopening stages (Feb 10/16/22)
workstaggergap2<-20; #Gap between Feb 16th and march 8th
schoolstaggergap<-8; #Gap between 2 stages of return to in-person learning (Feb 8/16)
inClen_w2=rep(46+workstaggergap1,49); #days between Dec 26th lockdown and Feb 16th main reopening day (46 days is to the 10th)
inClen_s2=rep(49,49); #days between Dec 21st first day of Christmas holiday, Feb 8th first reopening day
#Add in mods for workplaces in Hastings Prince Edward (Regions 8,9), Kingston, Frontenac and Lennox & Addington (Regions 6,7), and Renfrew County (Region 38) which reopen 6 days earlier on Feb 10
inClen_w2[c(6,7,8,9,38)]<-(inClen_w2[c(6,7,8,9,38)]-workstaggergap1)
#Add in mod for workplaces in York (14) reopening 6 days later on Feb 22
inClen_w2[c(14)]<-(inClen_w2[c(14)]+workstaggergap1)
#Add in mods for workplaces in Toronto (15), Peel (16), North Bay - Parry Sound (39,40) reopening 20 days later on March 8th
inClen_w2[c(15,16,39,40)]<-(inClen_w2[c(15,16,39,40)]+workstaggergap2)
#Add in mods for schools in Toronto (15), Peel (16), and York (14) reopening 8 days later on feb 16th
inClen_s2[c(14,15,16)]<-(inClen_s2[c(14,15,16)]+schoolstaggergap)
workclosuregap1=14 #Gap between day total cases >= 50 (Mar 10th) and day workplaces closed (March 25th)
schoolclosuregap1=3 #Gap between day total cases >= 50 (Mar 10th) and day schools closed for March Break (March 14th)
workclosuregap2=290 #Gap between day total cases >= 50 (Mar 10th) and day workplaces re-closed (Dec 26th)
schoolclosuregap2=285 #Gap between day total cases >= 50 (Mar 10th) and day schools re-closed (Dec 21st)
schoolbreakgap=113; #Gap between day total cases >= 50 (Mar 10th) and day schools would have closed for Summer Holidays (July 1st)
# Specification of response framework events (Look at `agedat[,c("Date", "ts50")]` to find corresponding tepi to each date, each day is 1 less than what's expected in tepi!)
buffer = 14 # Time between announcement of a tier change and its implementation
if(disable_response_framework){rf_start <- 1e8}
omggap=144 #Gap between day total cases >= 50 (Mar 10th) and day we switch to wave 2 omega value (Aug 1st)
Resurge_w=50 #Duration of additional closures
Resurge_s=50
NP=ncol(parms)-nrow(parms)
#Dummy start values for closures s.t. we can do counterfactuals for first wave
inCstart_w=50;
inCstart_s=50;
if (cftype %in% c("workopen", "bothopen")) {inCstart_w=1e8;} #Set so workplaces never close
years<- 1
#Defining model state space. Tn, Tk, Da, and Di are all untested, tested, asymptomatics, and infecteds respectively.
#Nt tracks cumulative # positive cases (including those recovered)
#C tracks # days since last closure, but in output msim converts all positive C entries into eps
#VD indicates level of NPI adherence from individuals
#Sick indicates all individuals who are in any of E, P, A, I (i.e. all those either exposed or currently infectious)
S=c("S1", "S2", "S3", "S4", "S5"); E=c("E1", "E2","E3", "E4", "E5"); R=c("R1", "R2", "R3", "R4","R5");
Da=c("A1","Ak1","SA1","SAk1", "A2","Ak2","SA2","SAk2", "A3","Ak3","SA3","SAk3", "A4","Ak4","SA4","SAk4", "A5","Ak5","SA5","SAk5")
Di=c("I1","Ik1","SI1","SIk1", "I2","Ik2","SI2","SIk2", "I3","Ik3","SI3","SIk3", "I4","Ik4","SI4","SIk4", "I5","Ik5","SI5","SIk5")
Tn=c("A1","SA1","I1","SI1","A2","SA2","I2","SI2","A3","SA3","I3","SI3","A4","SA4","I4","SI4","A5","SA5","I5","SI5")
Tk=c("Ak1","SAk1","Ik1","SIk1","Ak2","SAk2","Ik2","SIk2","Ak3","SAk3","Ik3","SIk3","Ak4","SAk4","Ik4","SIk4","Ak5","SAk5","Ik5","SIk5")
All1<-c("S1", "E1", "R1", "A1","Ak1","SA1","SAk1", "I1","Ik1","SI1","SIk1"); All2<-c("S2", "E2", "R2", "A2","Ak2","SA2","SAk2", "I2","Ik2","SI2","SIk2"); All3<-c("S3", "E3", "R3", "A3","Ak3","SA3","SAk3", "I3","Ik3","SI3","SIk3"); All4<-c("S4", "E4", "R4", "A4","Ak4","SA4","SAk4", "I4","Ik4","SI4","SIk4"); All5<-c("S5", "E5", "R5", "A5","Ak5","SA5","SAk5", "I5","Ik5","SI5","SIk5");
sick1<-c("E1", "A1","Ak1","SA1","SAk1", "I1","Ik1","SI1","SIk1"); sick2<-c("E2", "A2","Ak2","SA2","SAk2", "I2","Ik2","SI2","SIk2"); sick3<-c("E3", "A3","Ak3","SA3","SAk3", "I3","Ik3","SI3","SIk3"); sick4<-c("E4", "A4","Ak4","SA4","SAk4", "I4","Ik4","SI4","SIk4"); sick5<-c("E5", "A5","Ak5","SA5","SAk5", "I5","Ik5","SI5","SIk5");
symp1<-c("I1","Ik1","SI1","SIk1"); symp2<-c("I2","Ik2","SI2","SIk2"); symp3<-c("I3","Ik3","SI3","SIk3"); symp4<-c("I4","Ik4","SI4","SIk4"); symp5<-c("I5","Ik5","SI5","SIk5");
Snm=c(S,E,Da,Di,R,"Nt","Cw", "Cs", "C", "Nt1","Nt2","Nt3","Nt4","Nt5", "Response_Framework", "VD");
#these functions handle all the state transitions. Input x is a matrix where 1st half of columns are source states and 2nd half are destination states
gpTransB=function(x,Prs,seed,nc=ncol(x)){
xvp=cbind(as.vector(x[,1:(nc/2)]),as.vector(Prs))
if(max(xvp[,1])==0) return(x); nz=(xvp[,1]*xvp[,2])>0; xvp[!nz,1]=0;
set.seed(seed); xvp[nz,1]=apply(matrix(xvp[nz,],ncol=2),1,function(y) rbinom(1,y[1],y[2]));
return(x+matrix(c(-xvp[,1],xvp[,1]),ncol=nc))
}
#gpTrans is a simplified version where one transition probability applies to all states.
#If recovery=TRUE have individuals from 1st columns of x all transitioning into the last column
gpTrans=function(x,Pr,seed,Recovery=FALSE, nc=ncol(x)){
xv=as.vector(x[,1:c(nc/2,nc-1)[1+Recovery]])
if(max(xv)==0) return(x); set.seed(seed); xv[xv>0]=sapply(xv[xv>0], function(y) rbinom(1,y,Pr));
if(Recovery){ Tr=matrix(xv,ncol=nc-1); return(x+cbind(-Tr,rowSums(Tr))); }; return(x+matrix(c(-xv,xv),ncol=nc));
}
#Transition probabilities for travel. Multinomial faster than many binomials. rs=TRUE returns just total # people going to each province
reshfl2=function(x,M,seed,rs=TRUE,L=ncol(M),xnm=diag(x)){
set.seed(seed); if(max(x)>0) xnm[,x>0]=apply(matrix(rbind(x,M)[,x>0],nrow=L+1), 2, function(y) rmultinom(1,y[1],y[-1]));
if(rs) return(rowSums(xnm)); return(xnm);
}
#Modifier of travel matrix as people sick and/or tested positive less likely to travel by a proportion pstay
Mstay=function(M,pstay,Mod=M*(-(diag(ncol(M))-1)*(1-pstay))) Mod+diag(1-colSums(Mod))
meansd=function(x,wtR=1+x*0,wts=wtR/sum(wtR)){ xm=weighted.mean(x,wts); return(c(xm,sqrt(sum(wts*(x-xm)^2)))); }
#Main function handling all within-day transitions over state space S
m3iter=function(S,parms,timeinfo,seed,Ns=parms[,"N"]){
tm <- timeinfo[1]
tepi <- timeinfo[2]
# Timestep messages
if((!supercomputer_mode) & (tm %% printing_timestep == 0)){message("------------------ ", "Day: ", tm, " ------------------")}
if((!supercomputer_mode) & tepi_message){
message("------------------ ", "Date: ", as.Date("2020-03-10") + tepi + 1, " (tepi = ", tepi, ")", " ------------------")}
## Ramp up testing
# For epi states P, A
testPA1<- if(timeinfo[2]<0) {parms[,"taumax"]*0;} else {parms[1,"kappa"]*parms[,"taumax"]*(1-exp(-parms[1,"psi1"]*timeinfo[2]));}
testPA2<- if(timeinfo[2]<0) {parms[,"taumax"]*0;} else {parms[1,"kappa"]*parms[,"taumax"]*(1-exp(-parms[1,"psi2"]*timeinfo[2]));}
testPA3<- if(timeinfo[2]<0) {parms[,"taumax"]*0;} else {parms[1,"kappa"]*parms[,"taumax"]*(1-exp(-parms[1,"psi3"]*timeinfo[2]));}
testPA4<- if(timeinfo[2]<0) {parms[,"taumax"]*0;} else {parms[1,"kappa"]*parms[,"taumax"]*(1-exp(-parms[1,"psi4"]*timeinfo[2]));}
testPA5<- if(timeinfo[2]<0) {parms[,"taumax"]*0;} else {parms[1,"kappa"]*parms[,"taumax"]*(1-exp(-parms[1,"psi5"]*timeinfo[2]));}
# For epi state I
testI1<- if(timeinfo[2]<0) {parms[,"tau0"];} else {parms[,"taumax"] - (parms[,"taumax"] - parms[,"tau0"])*exp(-parms[1,"psi1"]*timeinfo[2]);}
testI2<- if(timeinfo[2]<0) {parms[,"tau0"];} else {parms[,"taumax"] - (parms[,"taumax"] - parms[,"tau0"])*exp(-parms[1,"psi2"]*timeinfo[2]);}
testI3<- if(timeinfo[2]<0) {parms[,"tau0"];} else {parms[,"taumax"] - (parms[,"taumax"] - parms[,"tau0"])*exp(-parms[1,"psi3"]*timeinfo[2]);}
testI4<- if(timeinfo[2]<0) {parms[,"tau0"];} else {parms[,"taumax"] - (parms[,"taumax"] - parms[,"tau0"])*exp(-parms[1,"psi4"]*timeinfo[2]);}
testI5<- if(timeinfo[2]<0) {parms[,"tau0"];} else {parms[,"taumax"] - (parms[,"taumax"] - parms[,"tau0"])*exp(-parms[1,"psi5"]*timeinfo[2]);}
if(testPA1 > testI1 || testPA2 > testI2 || testPA3 > testI3 || testPA4 > testI4 || testPA5 > testI5) {print("problem with testing rates"); invisible(readline(prompt="Press [enter] to continue"));}
#Implement testing (test results coming back from previous day)
S0k=S[,Tk]; S0k_1=S[,Tk[1:4]]; S0k_2=S[,Tk[5:8]]; S0k_3=S[,Tk[9:12]]; S0k_4=S[,Tk[13:16]]; S0k_5=S[,Tk[17:20]];
S0n_1=S[,Tn[1:4]]; S0n_2=S[,Tn[5:8]]; S0n_3=S[,Tn[9:12]]; S0n_4=S[,Tn[13:16]]; S0n_5=S[,Tn[17:20]];
S[,c(Tn,Tk)]=gpTransB(S[,c(Tn,Tk)], as.vector(cbind(testPA1,testPA1,testI1,testI1,testPA2,testPA2,testI2,testI2,testPA3,testPA3,testI3,testI3,testPA4,testPA4,testI4,testI4,testPA5,testPA5,testI5,testI5)),seed+40);
#calculate pos, the vector of local active case prevalence
S[,"Nt"]=S[,"Nt"]+rowSums(S[,Tk]-S0k); pos=rowSums(S[,Tk])/Ns; posglobal=(sum(S[,Tk])/sum(Ns));
S[,"Nt1"]=S[,"Nt1"]+rowSums(S[,Tk[1:4]]-S0k_1);
S[,"Nt2"]=S[,"Nt2"]+rowSums(S[,Tk[5:8]]-S0k_2);
S[,"Nt3"]=S[,"Nt3"]+rowSums(S[,Tk[9:12]]-S0k_3);
S[,"Nt4"]=S[,"Nt4"]+rowSums(S[,Tk[13:16]]-S0k_4);
S[,"Nt5"]=S[,"Nt5"]+rowSums(S[,Tk[17:20]]-S0k_5);
#Disease progression: zeta is the fraction of people who never show symptoms (modeled implicitly)
zeta=0.2;
### Symptomatic removals by age class
S[,c(Di[1:4],R[1])]=gpTrans(S[,c(Di[1:4],R[1])],parms[1,"rho"],seed,TRUE);
S[,c(Di[5:8],R[2])]=gpTrans(S[,c(Di[5:8],R[2])],parms[1,"rho"],seed+1,TRUE);
S[,c(Di[9:12],R[3])]=gpTrans(S[,c(Di[9:12],R[3])],parms[1,"rho"],seed+2,TRUE);
S[,c(Di[13:16],R[4])]=gpTrans(S[,c(Di[13:16],R[4])],parms[1,"rho"],seed+3,TRUE);
S[,c(Di[17:20],R[5])]=gpTrans(S[,c(Di[17:20],R[5])],parms[1,"rho"],seed+4,TRUE);
### Asymptomatic removals by age class
S[,c(Da[1:4],R[1])]=gpTrans(S[,c(Da[1:4],R[1])],zeta*prod(parms[1,c("sig","rho")]),seed,TRUE);
S[,c(Da[5:8],R[2])]=gpTrans(S[,c(Da[5:8],R[2])],zeta*prod(parms[1,c("sig","rho")]),seed+1,TRUE);
S[,c(Da[9:12],R[3])]=gpTrans(S[,c(Da[9:12],R[3])],zeta*prod(parms[1,c("sig","rho")]),seed+2,TRUE);
S[,c(Da[13:16],R[4])]=gpTrans(S[,c(Da[13:16],R[4])],zeta*prod(parms[1,c("sig","rho")]),seed+3,TRUE);
S[,c(Da[17:20],R[5])]=gpTrans(S[,c(Da[17:20],R[5])],zeta*prod(parms[1,c("sig","rho")]),seed+4,TRUE);
### Transition from pre-symptomatic to symptomatic by age class
S[,c(Da[1:4],Di[1:4])]=gpTrans(S[,c(Da[1:4],Di[1:4])],parms[1,"sig"]*(1-zeta),seed+5);
S[,c(Da[5:8],Di[5:8])]=gpTrans(S[,c(Da[5:8],Di[5:8])],parms[1,"sig"]*(1-zeta),seed+6);
S[,c(Da[9:12],Di[9:12])]=gpTrans(S[,c(Da[9:12],Di[9:12])],parms[1,"sig"]*(1-zeta),seed+7);
S[,c(Da[13:16],Di[13:16])]=gpTrans(S[,c(Da[13:16],Di[13:16])],parms[1,"sig"]*(1-zeta),seed+8);
S[,c(Da[17:20],Di[17:20])]=gpTrans(S[,c(Da[17:20],Di[17:20])],parms[1,"sig"]*(1-zeta),seed+9);
### Shift from exposed to asymptomatic by age class
S[,c("E1","A1")]=gpTrans(S[,c("E1","A1")],parms[1,"alpha"]*(1-parms[1,"s"]),seed+10);
S[,c("E2","A2")]=gpTrans(S[,c("E2","A2")],parms[1,"alpha"]*(1-parms[1,"s"]),seed+11);
S[,c("E3","A3")]=gpTrans(S[,c("E3","A3")],parms[1,"alpha"]*(1-parms[1,"s"]),seed+12);
S[,c("E4","A4")]=gpTrans(S[,c("E4","A4")],parms[1,"alpha"]*(1-parms[1,"s"]),seed+13);
S[,c("E5","A5")]=gpTrans(S[,c("E5","A5")],parms[1,"alpha"]*(1-parms[1,"s"]),seed+14);
### Shift from exposed to superspreader asymptomatic by age class
S[,c("E1","SA1")]=gpTrans(S[,c("E1","SA1")],parms[1,"alpha"]*parms[1,"s"],seed+15);
S[,c("E2","SA2")]=gpTrans(S[,c("E2","SA2")],parms[1,"alpha"]*parms[1,"s"],seed+16);
S[,c("E3","SA3")]=gpTrans(S[,c("E3","SA3")],parms[1,"alpha"]*parms[1,"s"],seed+17);
S[,c("E4","SA4")]=gpTrans(S[,c("E4","SA4")],parms[1,"alpha"]*parms[1,"s"],seed+18);
S[,c("E5","SA5")]=gpTrans(S[,c("E5","SA5")],parms[1,"alpha"]*parms[1,"s"],seed+19);
closed_s <- parms[,"eps_s"];
closed_w <- parms[,"eps_w"];
closed_h <- parms[,"eps_h"];
closed_o <- parms[,"eps_o"];
# The hard coded shutdowns activate before the colour coded scheme gets implemented and also after the boxing day provincial shutdown
if(!between(tepi, rf_start, rf_end)){
# Conditional statements for opening/closing workplaces and schools
if(cftype %in% c("workopen", "neitheropen")){
if(timeinfo[3]==-1 || timeinfo[2]<schoolclosuregap1) closed_s = 0*parms[,"eps_s"]; #We have not yet reached >=50 cases (prior to Mar 10) or >=50 cases reached, schools not yet closed (Mar 10 - Mar 13)
if(timeinfo[3]>=schoolclosuregap1 && timeinfo[3]<schoolclosuregap1+inClen_s1) closed_s = parms[,"eps_s"]; #Initial school closure started (March 14-Sept 7)
if(timeinfo[3]>=schoolclosuregap1+inClen_s1 && timeinfo[3]< schoolclosuregap2 && reopeningtype=="restricted") closed_s =parms[1,"eps_s"]*parms[,"reopen_s"]; #Schools reopen with covid regs in place
if(timeinfo[3]>=schoolclosuregap1+inClen_s1 && timeinfo[3]< schoolclosuregap2 && reopeningtype=="unrestricted") closed_s =0*parms[,"eps_s"]; #Schools reopen WITHOUT covid regs in place
if (timeinfo[3]>=schoolclosuregap2) {
if (reopeningtype=="restricted") {closed_s <- ifelse(timeinfo[3]<schoolclosuregap2+inClen_s2, parms[,"eps_s"], parms[1,"eps_s"]*parms[,"reopen_s"]);} #Christmas holiday to Boxing day lockdown to stay at home, with staggered reopening
if (reopeningtype=="unrestricted") {closed_s <- ifelse(timeinfo[3]<schoolclosuregap2+inClen_s2, parms[,"eps_s"], 0*parms[,"reopen_s"]);} #Christmas holiday to Boxing day lockdown to stay at home, with staggered reopening
}
}
if(cftype %in% c("schoolopen", "bothopen")){
if(timeinfo[3]==-1 || timeinfo[2]<schoolbreakgap) closed_s = 0*parms[,"eps_s"]; #We have not yet reached >=50 cases (prior to Mar 10) or >=50 cases reached, schools not yet closed (Mar 10 - June 30)
if(timeinfo[3]>=schoolbreakgap && timeinfo[3]<schoolbreakgap+inBlen_s) closed_s = parms[,"eps_s"]; #Initial summer school break started (July 1st-Sept 8th)
if(timeinfo[3]>=schoolbreakgap+inBlen_s && timeinfo[3]< schoolclosuregap2 && reopeningtype=="restricted") closed_s =parms[1,"eps_s"]*parms[,"reopen_s"]; #Schools reopen with covid regs in place
if(timeinfo[3]>=schoolbreakgap+inBlen_s && timeinfo[3]< schoolclosuregap2 && reopeningtype=="unrestricted") closed_s =0*parms[,"eps_s"]; #Schools reopen WITHOUT covid regs in place
if (timeinfo[3]>=schoolclosuregap2) {
if (reopeningtype=="restricted") {closed_s <- ifelse(timeinfo[3]<schoolclosuregap2+inClen_s2, parms[,"eps_s"], parms[1,"eps_s"]*parms[,"reopen_s"]);} #Christmas holiday to Boxing day lockdown to stay at home, with staggered reopening
if (reopeningtype=="unrestricted") {closed_s <- ifelse(timeinfo[3]<schoolclosuregap2+inClen_s2, parms[,"eps_s"], 0*parms[,"reopen_s"]);} #Christmas holiday to Boxing day lockdown to stay at home, with staggered reopening
}
}
if(timeinfo[4]==-1 || timeinfo[2]<workclosuregap1) closed_w = 0*parms[,"eps_w"]; #We have not yet reached >=50 cases (prior to Mar 10) or >=50 cases reached, workplaces not yet closed (Mar 10 - Mar 24)
if(timeinfo[4]>=workclosuregap1 && timeinfo[4]<workclosuregap1+inClen_w1) {closed_w = parms[,"eps_w"];}#Initial workplace closure started (March 25-June 11th)
if(timeinfo[4]>=workclosuregap1+inClen_w1 && timeinfo[4]< workclosuregap2 && reopeningtype=="restricted") closed_w =parms[1,"eps_w"]*parms[,"reopen_w"]; #Workplaces reopen with covid regs in place
if(timeinfo[4]>=workclosuregap1+inClen_w1 && timeinfo[4]< workclosuregap2 && reopeningtype=="unrestricted") closed_w = 0*parms[,"eps_w"]; #Workplaces reopen WITHOUT covid regs in place
if (timeinfo[4]>=workclosuregap2) {
if (reopeningtype=="restricted") {closed_w <- ifelse(timeinfo[4]<workclosuregap2+inClen_w2, parms[,"eps_w"], parms[1,"eps_w"]*parms[,"reopen_w"]);} #Boxing day lockdown to stay at home, with staggered reopening
if (reopeningtype=="unrestricted") {closed_w <- ifelse(timeinfo[4]<workclosuregap2+inClen_w2, parms[,"eps_w"], 0*parms[,"reopen_w"]);} #Boxing day lockdown to stay at home, with staggered reopening
}
}
S[,"Cs"] = closed_s;
S[,"Cw"] = closed_w;
#Make modified travel matrices for people feeling sick and/or tested positive, then implement travel
M=Mc=parms[,-(1:NP)]; Mc=M[1:nrow(M),]*(1-closed_w)*(1-closed_s)*(1-closed_h)*(1-closed_o); diag(Mc)=diag(Mc)+1-colSums(Mc);
### Revamping McA to include age specific travel rates, first of each pair is for old/young, second for middle
McA=abind(Mstay(Mc,parms[1,"atravel"]), Mc, Mstay(Mc,1-(1-parms[1,"atravel"])*(1-parms[1,"eta"])), Mstay(Mc,parms[1,"eta"]), Mstay(Mc,1-(1-parms[1,"atravel"])*(1-parms[1,"r"])), Mstay(Mc,parms[1,"r"]), Mstay(Mc,1-(1-parms[1,"eta"])*(1-parms[1,"r"])*(1-parms[1,"atravel"])), Mstay(Mc,1-(1-parms[1,"eta"])*(1-parms[1,"r"])), along=3);
#Implement travel
### Do Ss for however many age classes you have, added atravel for age-class specific travel
Ss=abind(reshfl2(S[,"S1"],Mstay(Mc,parms[1,"atravel"]),seed+20,FALSE),reshfl2(S[,"S2"],Mc,seed+21,FALSE),reshfl2(S[,"S3"],Mc,seed+22,FALSE),reshfl2(S[,"S4"],Mstay(Mc,parms[1,"atravel"]),seed+23,FALSE),reshfl2(S[,"S5"],Mstay(Mc,parms[1,"atravel"]),seed+24,FALSE),along=3);
Rearr=apply(rbind(seed+(25:34), c(c(1,2,2,1,1),c(1,2,2,1,1),c(1,3,1,3,2,4,2,4,2,4,2,4,1,3,1,3,1,3,1,3),c(5,7,5,7,6,8,6,8,6,8,6,8,5,7,5,7,5,7,5,7)), S[,c(R,E,Da,Di)]), 2, function(x) reshfl2(x[-(1:2)],McA[,,x[2]],x[1]))
#Age specific contacts, rows are age classes, columns are their contact age classes
ageSpecifics_w<-cmat[,,1] ## age specific contacts for work
ageSpecifics_s<-cmat[,,2] ## age specific contacts for school
ageSpecifics_h<-cmat[,,3] ## age specific contacts for home
ageSpecifics_o<-cmat[,,4] ## age specific contacts for other
#Seasonal forcing
scomp<-1+parms[,"B"]*cos((2*pi/365)*(timeinfo[1] + parms[,"phi"]))
S[, "VD"]<-(1-exp(-parms[1,"omg"]*pos));
if (timeinfo[4]>=workclosuregap2 + 20) {
S[, "VD"] <- ifelse(timeinfo[4]<workclosuregap2+inClen_w2, (1-exp(-(parms[1,"omg"]*pos + parms[1,"boost"]))), (1-exp(-parms[1,"omg"]*pos))) #Stay at home, with staggered reopening
}
if (vdtype=="vdOFF") {S[, "VD"]<-0*pos;}
#Base infection probabilities
Infect1 = scomp*parms[,"a1"]*parms[,"beta"]*((1-closed_w)%*%t(ageSpecifics_w[1,]) + (1-closed_s)%*%t(ageSpecifics_s[1,]) + (1-parms[1,"eps_h"]*S[, "VD"])%*%t(ageSpecifics_h[1,]) + (1-parms[1,"eps_o"]*S[, "VD"])%*%t(ageSpecifics_o[1,]))
Infect2 = scomp*parms[,"a2"]*parms[,"beta"]*((1-closed_w)%*%t(ageSpecifics_w[2,]) + (1-closed_s)%*%t(ageSpecifics_s[2,]) + (1-parms[1,"eps_h"]*S[, "VD"])%*%t(ageSpecifics_h[2,]) + (1-parms[1,"eps_o"]*S[, "VD"])%*%t(ageSpecifics_o[2,]))
Infect3 = scomp*parms[,"a3"]*parms[,"beta"]*((1-closed_w)%*%t(ageSpecifics_w[3,]) + (1-closed_s)%*%t(ageSpecifics_s[3,]) + (1-parms[1,"eps_h"]*S[, "VD"])%*%t(ageSpecifics_h[3,]) + (1-parms[1,"eps_o"]*S[, "VD"])%*%t(ageSpecifics_o[3,]))
Infect4 = scomp*parms[,"a4"]*parms[,"beta"]*((1-closed_w)%*%t(ageSpecifics_w[4,]) + (1-closed_s)%*%t(ageSpecifics_s[4,]) + (1-parms[1,"eps_h"]*S[, "VD"])%*%t(ageSpecifics_h[4,]) + (1-parms[1,"eps_o"]*S[, "VD"])%*%t(ageSpecifics_o[4,]))
Infect5 = scomp*parms[,"a5"]*parms[,"beta"]*((1-closed_w)%*%t(ageSpecifics_w[5,]) + (1-closed_s)%*%t(ageSpecifics_s[5,]) + (1-parms[1,"eps_h"]*S[, "VD"])%*%t(ageSpecifics_h[5,]) + (1-parms[1,"eps_o"]*S[, "VD"])%*%t(ageSpecifics_o[5,]))
#Class-specific infection modifiers
modK=1-parms[1,"eta"]; modS=(1/parms[1,"s"])-1;
# modA=cbind(Infect,modK*Infect,modS*Infect,modS*modK*Infect); # Replaced with modA1,2,...
#Introduce age specific modA 3-D arrays for not superspreader or known, not supersrpeader but known, superspreader not known, superspreader and known
modA1=abind(Infect1,modK*Infect1,modS*Infect1,modS*modK*Infect1,along=3);
modA2=abind(Infect2,modK*Infect2,modS*Infect2,modS*modK*Infect2,along=3);
modA3=abind(Infect3,modK*Infect3,modS*Infect3,modS*modK*Infect3,along=3);
modA4=abind(Infect4,modK*Infect4,modS*Infect4,modS*modK*Infect4,along=3);
modA5=abind(Infect5,modK*Infect5,modS*Infect5,modS*modK*Infect5,along=3);
#Flatten into 2-D arrays where order is based on age class to match Rearr which is ordered as (all pre/asympt by age class, all sympt by age class)
modAbind1<-cbind(modA1[,1,],modA1[,2,],modA1[,3,],modA1[,4,],modA1[,5,]);
modAbind2<-cbind(modA2[,1,],modA2[,2,],modA2[,3,],modA2[,4,],modA2[,5,]);
modAbind3<-cbind(modA3[,1,],modA3[,2,],modA3[,3,],modA3[,4,],modA3[,5,]);
modAbind4<-cbind(modA4[,1,],modA4[,2,],modA4[,3,],modA4[,4,],modA4[,5,]);
modAbind5<-cbind(modA5[,1,],modA5[,2,],modA5[,3,],modA5[,4,],modA5[,5,]);
# Overall infection Pr is then 1-Pr(avoid infection by anyone)
Infects1=1 - apply((1-cbind(modAbind1, 2*modAbind1))^Rearr[,-(1:10)], 1, prod)
Infects2=1 - apply((1-cbind(modAbind2, 2*modAbind2))^Rearr[,-(1:10)], 1, prod)
Infects3=1 - apply((1-cbind(modAbind3, 2*modAbind3))^Rearr[,-(1:10)], 1, prod)
Infects4=1 - apply((1-cbind(modAbind4, 2*modAbind4))^Rearr[,-(1:10)], 1, prod)
Infects5=1 - apply((1-cbind(modAbind5, 2*modAbind5))^Rearr[,-(1:10)], 1, prod)
#Implement infection and move susceptibles and newly exposeds back to home county
#For each Ss[,,i], entires in each column are individuals from the same region, with the rows showing if/where they travelled (so row sums give current total people in a region including visitors)
S[,c("S1","E1")]=cbind(0,S[,"E1"]) + colSums(gpTransB(cbind(Ss[,,1],0*Ss[,,1]),round(Infects1,10),seed+35))
S[,c("S2","E2")]=cbind(0,S[,"E2"]) + colSums(gpTransB(cbind(Ss[,,2],0*Ss[,,2]),round(Infects2,10),seed+36))
S[,c("S3","E3")]=cbind(0,S[,"E3"]) + colSums(gpTransB(cbind(Ss[,,3],0*Ss[,,3]),round(Infects3,10),seed+37))
S[,c("S4","E4")]=cbind(0,S[,"E4"]) + colSums(gpTransB(cbind(Ss[,,4],0*Ss[,,4]),round(Infects4,10),seed+38))
S[,c("S5","E5")]=cbind(0,S[,"E5"]) + colSums(gpTransB(cbind(Ss[,,5],0*Ss[,,5]),round(Infects5,10),seed+39))
return(S)
}; FUN=m3iter
#Implement initial closure and changes in testing probability
closeinappl=function(parms,TS,tm=dim(TS)[3],delayInit=10){
Nta=colSums(t(t(TS[,"Nt",])));
omgs=cbind(parms[,"omg"],0);
rampdays1=tm-(which(Nta>=inCstart)[1]+158-1) #Number of days past the beginning of the ramp-down
parms[,"omg"]=pmax(omgs[,1]*exp(-parms[1,"zeta"]*rampdays1),omgs[,2]) #Ramp-down the omega value from initial to 2nd wave value
if( (max(Nta)>=inCstart) & (tm-which(Nta>=inCstart)[1])<(158-1) ) { parms[,"omg"]=omgs[,1];} #NPI adherence with risk perception coeff omg_0 before ramp down begins
if((max(Nta)<inCstart)) parms[,"omg"]=0; #No NPI adherence before start of pandemic (as inCstart is March 10th when total cases>=50)
return(parms);
}
#Pulls info on what timestep it is
gettime=function(TS,tm=dim(TS)[3]){
tsNt=colSums(t(t(TS[,"Nt",])));
if(max(tsNt)>=inCstart) {tepi<-length(tsNt[tsNt>=inCstart]) -1} else {tepi<--1} #Calc days into epidemic (since >=50 cases)
if(max(tsNt)>=inCstart_s) {tstart_s<-length(tsNt[tsNt>=inCstart_s]) -1} else {tstart_s<--1} #Calc days past trigger date for school closures (==tepi for no counterfactuals)
if(max(tsNt)>=inCstart_w) {tstart_w<-length(tsNt[tsNt>=inCstart_w]) -1} else {tstart_w<--1} #Calc days past trigger date for work closures (==tepi for no counterfactuals)
timeinfo=c(tm, tepi, tstart_s, tstart_w)
return(timeinfo);
}
### vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv Response Framework Code vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ###
# Code for the color-coded regional restrictions (Ontario's COVID-19 Response Framework)
# This includes the 5 zones described at https://www.ontario.ca/page/covid-19-response-framework-keeping-ontario-safe-and-open
# (above the website has since been taken down, use WayBack Machine to find an archived version)
# and includes the "Shutdown" zone which is a province wide restriction that is more strict than "Lockdown"
# zones = c("Prevent", "Protect", "Restrict", "Control", "Lockdown", "Shutdown")
### Constants
# Weekly Incident Rate Thresholds
if("wir" %in% indicators_active){
if(!supercomputer_mode){message("Weekly incidence rate active")}
wir_shutdown_threshold <- mu * 100 # Guidelines not clear, determined from eyeballing data
wir_lockdown_threshold <- mu * 100 # Guidelines not clear, determined from eyeballing data
wir_control_threshold <- mu * 40
wir_restrict_threshold <- mu * 25
wir_protect_threshold <- mu * 10
} else {
wir_shutdown_threshold <- 1e6
wir_lockdown_threshold <- 1e6
wir_control_threshold <- 1e6
wir_restrict_threshold <- 1e6
wir_protect_threshold <- 1e6
}
# Percent Positivity Thresholds
if("ppos" %in% indicators_active){
if(!supercomputer_mode){message("Percent positivity active")}
ppos_shutdown_threshold <- mu * 6 # Guidelines not clear, determined from eyeballing data
ppos_lockdown_threshold <- mu * 6 # Guidelines not clear, determined from eyeballing data
ppos_control_threshold <- mu * 2.5
ppos_restrict_threshold <- mu * 1.3
ppos_protect_threshold <- mu * 0.5
} else {
ppos_shutdown_threshold <- 1e6
ppos_lockdown_threshold <- 1e6
ppos_control_threshold <- 1e6
ppos_restrict_threshold <- 1e6
ppos_protect_threshold <- 1e6
}
# Reproduction Number Thresholds
if("Rt" %in% indicators_active){
if(!supercomputer_mode){message("Reproductive number active")}
Rt_shutdown_threshold <- mu * 1.4 # Guidelines not clear, determined from eyeballing data
Rt_lockdown_threshold <- mu * 1.4 # Guidelines not clear, determined from eyeballing data
Rt_control_threshold <- mu * 1.2
Rt_restrict_threshold <- mu * 1
Rt_protect_threshold <- mu * 0.95
} else {
Rt_shutdown_threshold <- 1e6
Rt_lockdown_threshold <- 1e6
Rt_control_threshold <- 1e6
Rt_restrict_threshold <- 1e6
Rt_protect_threshold <- 1e6
}
# Initialize the epsilon and alpha values
alpha_w1 <- parms[1, "alpha_w1"]
alpha_w2 <- parms[1, "alpha_w2"]
alpha_w3 <- parms[1, "alpha_w3"]
alpha_w4 <- parms[1, "alpha_w4"]
eps_w_shutdown <- parms[1, "eps_w"]
eps_w_lockdown <- eps_w_shutdown
eps_w_control <- alpha_w1 * eps_w_lockdown
eps_w_restrict <- alpha_w2 * eps_w_control
eps_w_protect <- alpha_w3 * eps_w_restrict
eps_w_prevent <- alpha_w4 * eps_w_protect
alpha_s1 <- parms[1, "alpha_s1"]
alpha_s2 <- parms[1, "alpha_s2"]
alpha_s3 <- parms[1, "alpha_s3"]
alpha_s4 <- parms[1, "alpha_s4"]
eps_s_shutdown <- parms[1, "eps_s"]
eps_s_lockdown <- eps_s_shutdown
eps_s_control <- alpha_s1 * eps_s_lockdown
eps_s_restrict <- alpha_s2 * eps_s_control
eps_s_protect <- alpha_s3 * eps_s_restrict
eps_s_prevent <- alpha_s4 * eps_s_protect
alpha_h1 <- parms[1, "alpha_h1"]
alpha_h2 <- parms[1, "alpha_h2"]
alpha_h3 <- parms[1, "alpha_h3"]
alpha_h4 <- parms[1, "alpha_h4"]
eps_h_shutdown <- parms[1, "eps_h"]
eps_h_lockdown <- eps_h_shutdown
eps_h_control <- alpha_h1 * eps_h_lockdown
eps_h_restrict <- alpha_h2 * eps_h_control
eps_h_protect <- alpha_h3 * eps_h_restrict
eps_h_prevent <- alpha_h4 * eps_h_protect
alpha_o1 <- parms[1, "alpha_o1"]
alpha_o2 <- parms[1, "alpha_o2"]
alpha_o3 <- parms[1, "alpha_o3"]
alpha_o4 <- parms[1, "alpha_o4"]
eps_o_shutdown <- parms[1, "eps_o"]
eps_o_lockdown <- eps_o_shutdown
eps_o_control <- alpha_o1 * eps_o_lockdown
eps_o_restrict <- alpha_o2 * eps_o_control
eps_o_protect <- alpha_o3 * eps_o_restrict
eps_o_prevent <- alpha_o4 * eps_o_protect
eps_df <- data.frame(work = c(eps_w_prevent, eps_w_protect, eps_w_restrict, eps_w_control, eps_w_lockdown, eps_w_shutdown),
school = c(eps_s_prevent, eps_s_protect, eps_s_restrict, eps_s_control, eps_s_lockdown, eps_s_shutdown),
home = c(eps_h_prevent, eps_h_protect, eps_h_restrict, eps_h_control, eps_h_lockdown, eps_h_shutdown),
other = c(eps_o_prevent, eps_o_protect, eps_o_restrict, eps_o_control, eps_o_lockdown, eps_o_shutdown),
row.names = c("Prevent", "Protect", "Restrict", "Control", "Lockdown", "Shutdown"))
### vvvv Functions to implement Ontario's colour-coded lockdown scheme vvvv ###
# tier_to_number: converts strings of a response_framework to an int.
tier_to_number <- function(response_framework, timeinfo){
# The response_framework input for this function is only for one day!!! (A 1-dimensional vector)
today = timeinfo[1]
tepi = timeinfo[2]
new_framework <- ifelse(response_framework == "Prevent", 1,
ifelse(response_framework == "Protect", 2,
ifelse(response_framework == "Restrict", 3,
ifelse(response_framework == "Control", 4,
ifelse(response_framework == "Lockdown", 5,
ifelse(response_framework == "Shutdown", 6,
-1
)
)
)
)
)
)
# Ensure that the value is 0 for all days before the response framework got implemented
if (tepi < rf_start){
new_framework = rep(0, length(new_framework))
}
return(new_framework)
}
# number_of_regions: Returns the number of (census) regions in the simulation
number_of_regions <- function(region_id = regionid){
return(dim(region_id)[1])
}
# create_response_framework: Creates an array with rows representing days since start of simulation (tm) and columns representing regions.
# 2D-array <- (string, int, 2D-array)
create_response_framework <- function(init_zone, buffer = 14, region_id = regionid){
# init_zone is the zone that all regions are in at the start of the simulation. Has to be an element of zones.
# buffer is the time between announcing a switch to a new zone and implementing the zone's restrictions
census_regions = region_id$census.region
num_of_census <- number_of_regions(region_id)
response_framework = array(init_zone, dim = c(1+buffer, num_of_census))
# print(response_framework)
return(response_framework)
}
# weekly_new_cases: Outputs the new cases/week for a specific day
# int <- (3D-dataframe, int)
weekly_new_cases <- function(time, TS){
one_week_ago = ifelse(time > 7, time - 7 + 1, 1) # slicing is inclusive in R so I have to add one to output a size 7 array.
result = TS[,"Nt", time] - TS[,"Nt", one_week_ago]
return(result)
}
# weekly_incidence_rate_regional: Updates the wir_time array with the weekly incidence rate per 100 000 for each region (columns) over time (rows).
# vector <- (3D-dataframe, 2D-array, 2D-array)
weekly_incidence_rate_regional <- function(wir_time, TS, region_id = regionid){
# Does nothing if wir was not activated.
if(! "wir" %in% indicators_active){
# print("wir not active")
return(wir_time)
}
# Define key variables to check conditions on
today = gettime(TS)[1]
tepi = gettime(TS)[2]
implementation_day = tepi + buffer + 1 # The value of tepi that the zone change will get implemented on. Off-by-one error present
# If response framework hasn't activated yet, don't go through with the calculation.
if(!between(implementation_day, rf_start, rf_end)){
wir_time = rbind(wir_time, -1)
return(wir_time) # Modify this so that it's the right size.
}
# Define the time two weeks ago
if (today > 14){ # If less than two weeks has passed since the start, then set two_weeks_ago <- 1
two_weeks_ago <- today - 14 + 1 # slicing is inclusive in R so I have to add one to output a size 14 array.
} else {
two_weeks_ago <- 1
}
# Calculates the weekly new cases for each census region for the past 2 weeks
weekly_new_cases_2wks = weekly_new_cases(two_weeks_ago:today, TS)
# Convert census region cases to PHU region cases
PHU_nums = region_id$phunum # Array to store each census region's PHU number
PHU_populations = aggregate(x = region_id[,"pop2016"],
by = list(region_id$phunum),
FUN = sum)$x # Array to store each PHU's population
weekly_new_cases_2wks_PHU = aggregate(x = weekly_new_cases_2wks,
by = list(region_id$phunum),
FUN = sum) # Calculate weekly new cases for each PHU for the past 2 weeks
weekly_new_cases_2wks_PHU = subset(weekly_new_cases_2wks_PHU, select = -c(Group.1)) # Get rid of the unnecessary column that was added from the aggregate function
weekly_new_cases_PHU = as.matrix(apply(weekly_new_cases_2wks_PHU, 1, mean)) # Calculate the daily average of the weekly new cases for each PHU based on data from the past 2 weeks
# Calculate the weekly incidence rate for each PHU, then expand the values to be the same for each census region with the same PHU.
weekly_incidence_rate_PHU_today = 100000*weekly_new_cases_PHU/PHU_populations # Calculate the weekly incidence rate for each PHU
weekly_incidence_rate_regional_today = weekly_incidence_rate_PHU_today[PHU_nums] # Spread the weekly incidence rate to census regions with the same PHU
# Append new weekly cases array to the wir_time array
wir_time <- rbind(wir_time, weekly_incidence_rate_regional_today)
return(wir_time)
}
# weekly_incidence_rate_provincial: Outputs the weekly incidence rate of the province.
# float <- (3D-array, 2D-array)
weekly_incidence_rate_provincial <- function(TS, region_id = regionid){
# Define key variables to check conditions on
today = gettime(TS)[1]
tepi = gettime(TS)[2]
implementation_day = tepi + buffer + 1 # The value of tepi that the zone change will get implemented on. Off-by-one error present
# If response framework hasn't activated yet, don't go through with the calculation.
if(!between(implementation_day, rf_start, rf_end)){
return(-1) # Modify this so that it's the right size.
}
if (today > 14){ # If less than two weeks has passed since the start, then set two_weeks_ago <- 1
two_weeks_ago <- today - 14 + 1 # slicing is inclusive in R so I have to add one to output a size 14 array.
} else {
two_weeks_ago <- 1
}
weekly_new_cases_2wks = colSums(weekly_new_cases(two_weeks_ago:today, TS)) # Calculates the weekly new cases for each census region for the past 2 weeks
provincial_population = sum(region_id$pop2016)
weekly_new_cases = mean(weekly_new_cases_2wks)
weekly_incidence_rate_provincial_today <- 100000*weekly_new_cases/provincial_population
return(weekly_incidence_rate_provincial_today)
}
# percent_positivitiy_regional: Calculates the % positivity for every census region for each day.
percent_positivitiy_regional <- function(ppos_time, TS, testing_volumes, region_id = regionid){
# Does nothing if ppos was not activated.
if(! "ppos" %in% indicators_active){
# print("ppos not active")
return(ppos_time)
}
# Define key variables to check conditions on
today = gettime(TS)[1]
tepi = gettime(TS)[2]
epi_sim_diff = today - tepi
implementation_day = tepi + buffer + 1 # The value of tepi that the zone change will get implemented on. Off-by-one error present
# If response framework hasn't activated yet, don't go through with the calculation.
if(!between(implementation_day, rf_start, rf_end)){
ppos_time = rbind(ppos_time, -1)
return(ppos_time) # Modify this so that it's the right size.
}
# If tepi is before the data records, then set ppos to -1 for that day.
min_tepi = testing_volumes$ts50[1]
if(tepi <= min_tepi){
ppos_time = rbind(ppos_time, -1)
return(ppos_time)
}
if (today > 14){ # If less than two weeks has passed since the start, then set two_weeks_ago <- 1
two_weeks_ago <- today - 14 + 1 # slicing is inclusive in R so I have to add one to output a size 14 array.
} else {
two_weeks_ago <- 1
}
if (tepi <= min_tepi + 14) { # Condition for days slightly after data starts
two_weeks_ago = min_tepi + epi_sim_diff + 1
}
# Define days for indexing
todays = two_weeks_ago:today
yesterdays = ifelse(todays > min_tepi + epi_sim_diff, todays - 1, todays)
new_pos_2wks_census = TS[,"Nt", todays] - TS[,"Nt", yesterdays] # Calculate the new positive cases for the past two weeks for each census region.
# Convert census region cases to PHU region cases
PHU_populations = aggregate(x = region_id[,"pop2016"],
by = list(region_id$phunum),
FUN = sum)$x # Array to store each PHU's population
new_pos_2wks_PHU = aggregate(x = new_pos_2wks_census,
by = list(region_id$phunum),
FUN = sum) # Calculate new positive cases for each PHU for the past 2 weeks
# Get rid of the unnecessary column that was added from the aggregate function and transpose
new_pos_2wks_PHU = subset(new_pos_2wks_PHU, select = -c(Group.1))
new_pos_2wks_PHU = t(new_pos_2wks_PHU)
# Extract testing data from 1 day before relative to the two weeks that we're examining
yesterday_tests = yesterdays - epi_sim_diff
num_of_PHUs = length(PHU_populations)
PHU_names = paste("phu.", c(1:num_of_PHUs), sep = "")
testing_2wks = testing_volumes[which(testing_volumes$ts50 %in% yesterday_tests), PHU_names]
# Calculate the percent positivity
ppos_PHU = 100*new_pos_2wks_PHU/testing_2wks
ppos_PHU = as.matrix(apply(ppos_PHU, 2, mean)) # Take the average over the two weeks
PHU_nums = region_id$phunum # Array to store each census region's PHU number
ppos_census = ppos_PHU[PHU_nums] # Convert PHU ppos into census regions
# Append new ppos values to ppos_time
ppos_time = rbind(ppos_time, ppos_census)
return(ppos_time)
}
# percent_positivitiy_provincial: Calculates the % positivity for the province.
percent_positivitiy_provincial <- function(TS, testing_volumes, region_id = regionid){
# Define key variables to check conditions on
today = gettime(TS)[1]
tepi = gettime(TS)[2]
epi_sim_diff = today - tepi
implementation_day = tepi + buffer + 1 # The value of tepi that the zone change will get implemented on. Off-by-one error present
# If response framework hasn't activated yet, don't go through with the calculation.
if(!between(implementation_day, rf_start, rf_end)){
return(-1) # Modify this so that it's the right size.
}
# If tepi is before the data records, then set ppos to -1 for that day.
min_tepi = testing_volumes$ts50[1]
if(tepi <= min_tepi){
return(-1)
}
if (today > 14){ # If less than two weeks has passed since the start, then set two_weeks_ago <- 1
two_weeks_ago <- today - 14 + 1 # slicing is inclusive in R so I have to add one to output a size 14 array.
} else {
two_weeks_ago <- 1
}
if (tepi <= min_tepi + 14) { # Condition for days slightly after data starts
two_weeks_ago = min_tepi + epi_sim_diff + 1
}
# Define days for indexing
todays = two_weeks_ago:today
yesterdays = ifelse(todays > min_tepi + epi_sim_diff, todays - 1, todays)
# Define new cases for the past two weeks for each census region
new_pos_2wks_census = (TS[,"Nt", todays] - TS[,"Nt", yesterdays])
if(is.null(dim(new_pos_2wks_census))){ # Base case for when new_pos_2wks_census has only one dimension (one row)
new_pos_2wks = sum(new_pos_2wks_census)
} else {
new_pos_2wks = colSums(new_pos_2wks_census)
}
# Extract testing data from 1 day before relative to the two weeks that we're examining
yesterday_tests = yesterdays - epi_sim_diff
provincial_population = sum(region_id$pop2016)
num_of_PHUs = length(unique(region_id$phunum))
PHU_names = paste("phu.", c(1:num_of_PHUs), sep = "")
testing_2wks = testing_volumes[which(testing_volumes$ts50 %in% yesterday_tests), PHU_names]
testing_2wks = rowSums(testing_2wks)
# Calculate the percent positivity and it's average over two weeks
perc_pos = 100*new_pos_2wks/testing_2wks
perc_pos = mean(perc_pos)
return(perc_pos)
}
# effective_reproduction_number: Calculates the Rt value given a new_cases array
effective_reproduction_number <- function(new_cases,
initial_active_cases,
rolling_window = 7){
# Define parameters for the serial interval
# https://www.publichealthontario.ca/-/media/data-files/covid-19-data-tool-technical-notes.pdf?la=en
mu = 4.5
sig = 2.5
k = seq(0,20)
si_distr = discr_si(k,mu,sig)
# Define the rolling window
t_end = length(new_cases)
t_start = ifelse(t_end <= rolling_window, 2, t_end - rolling_window + 1)
# Define the incid array
local = new_cases
imported = array(0, dim = c(t_end))
imported[1] = initial_active_cases + local[1]
local[1] = 0
incid = data.frame(local = local, imported = imported)
# -1 indicates that there wasn't enough data for the calculation to be accurate.
not_enough_data = -1
if(t_end < 5){
return(not_enough_data)
}
# Calculate the Rt value, return -1 if it's too early in the epidemic
output_R = tryCatch(
{estimate_R(
incid = incid,
method = "non_parametric_si",
config = make_config(list(
# incid = new_cases,
# method = method,
si_distr = si_distr,
# mean_si = mu,
# std_si = sig,
t_start = t_start,
t_end = t_end)
)
)},
warning = function(w){
# print(w)
if(w == warning("You're estimating R too early in the epidemic to get the desired
posterior CV.")){
# print(w)
# print("too early")
return(not_enough_data)
}
else {
print(w)
print("another warning has been triggered...")
return(-2)
}
}
)
# Checks on the output
if(is.numeric(output_R)){
Rt = not_enough_data
} else {
Rt = output_R$R$`Median(R)`
}
if(is.na(Rt)){
print("Rt contains NA")
print("placeholder")
print(output_R)
print("hi")
# Rt = not_enough_data
}
return(Rt)
}
# Rt_regional: Calculates Rt for every census region for the latest day.
Rt_regional <- function(Rt_time, TS, region_id = regionid){
# Does nothing if Rt was not activated.
if(! "Rt" %in% indicators_active){
# print("Rt not active")
return(Rt_time)
}
# Define the rolling window and other key variables to check conditions on
rolling_window = 7
rw_buffer = 2*rolling_window
today = gettime(TS)[1]
tepi = gettime(TS)[2]
implementation_day = tepi + buffer + 1 # The value of tepi that the zone change will get implemented on. Off-by-one error present
# If response framework hasn't activated yet, don't go through with the calculation.
if(!between(implementation_day, rf_start, rf_end)){
Rt_time = rbind(Rt_time, -1)
return(Rt_time)
}
if(tepi < 3){ # If not enough time has passed since the start of the epidemic, then output -1
col_len = dim(Rt_time)[2]
Rt_time = rbind(Rt_time, rep(-1,col_len))
return(Rt_time)
}
# Calculate dates
epi_sim_diff = today - tepi # Difference between simulation start and start of epidemic (Mar 10, 2020)
epi_start = as.Date("2020-03-10", format = "%Y-%m-%d") # start of epidemic (Mar 10, 2020)
end_date = epi_start + tepi # Most recent date of data reporting
two_weeks_ago = ifelse(tepi >= rw_buffer, today - rw_buffer, epi_sim_diff)
start_date = end_date - (today - two_weeks_ago)
dates = seq(from = start_date, to = end_date, by = "days")
# Indices used to extract daily cases
todays = c(two_weeks_ago:today)
yesterdays = todays - 1
# Calculate daily cases for each census region
new_cases_census = TS[,"Nt",todays] - TS[,"Nt",yesterdays]
new_cases_census = as.data.frame(t(new_cases_census))
num_of_census = number_of_regions(regionid)
census_nums = paste("census.", c(1:num_of_census), sep = "")
colnames(new_cases_census) = census_nums
reported_cases_census = as.data.frame(cbind(date = dates, new_cases_census))
# Convert census region cases to PHU region cases
PHU_nums = region_id$phunum # Array to store each census region's PHU number
PHU_populations = aggregate(x = region_id[,"pop2016"],
by = list(region_id$phunum),
FUN = sum)$x # Array to store each PHU's population
reported_cases_PHU = aggregate(x = t(reported_cases_census[,census_nums]),
by = list(region_id$phunum),
FUN = sum) # Calculate weekly new cases for each PHU for the past 2 weeks