https://github.com/FrancoisBlanquart/selection_variant
Tip revision: a242a18349393e2e98d353a879ef9e66e99f21c1 authored by François Blanquart on 13 December 2021, 07:50:23 UTC
Update README.md
Update README.md
Tip revision: a242a18
conceptual_figures_v2.R
figure_size_factor <- 1.4
figure_size_factor2 <- 1.6
mygray <- "gray60"
# must enter the first 18 lines of "inference_UK_France_vX.R" script
# conceptual figures
rtoR(r = 0.05, mu = MUW, SD = SDW)
Rtor(R = 2.5, mu = MUW, SD = SDW)
mylegend <- c("Historical", "Shorter mean generation time", "Longer mean generation time", "Larger variance", "Smaller variance")
for(metascenario in 1:2){
if(metascenario==1){
sc1 <- list(s1 = 0., s2 = 5.5/6.5-1, s3 = 0.)
sc2 <- list(s1 = 0., s2 = 7.5/6.5-1, s3 = 0.)
sc3 <- list(s1 = 0., s2 = 0., s3 = 0.4)
sc4 <- list(s1 = 0., s2 = 0., s3 = -0.4)
sc5 <- list(s1 = 0., s2 = 0., s3 = 0)
}
if(metascenario==2){
beta_advantage <- 0.1
sc1 <- list(s1 = beta_advantage, s2 = 5.5/6.5-1, s3 = 0.)
sc2 <- list(s1 = beta_advantage, s2 = 7.5/6.5-1, s3 = 0.)
sc3 <- list(s1 = beta_advantage, s2 = 0., s3 = 0.4)
sc4 <- list(s1 = beta_advantage, s2 = 0., s3 = -0.4)
sc5 <- list(s1 = beta_advantage, s2 = 0., s3 = 0)
}
cols <- c(RColorBrewer::brewer.pal(n = 8, name = "Paired")[1:4], mygray)
RW <- 1
get_mutant_par <- function(mysc){
return(
list(
RV = with(mysc, RW*(1+s1)),
MUV = with(mysc, MUW * (1+s2)),
SDV = with(mysc, SDW * (1+s3)),
shapeV = with(mysc, (MUW * (1+s2))^2/(SDW * (1+s3))^2),
scaleV = with(mysc, (SDW * (1+s3))^2/( MUW * (1+s2)))
)
)
}
x <- seq(0, 20, 0.1)
pdf(paste0("~/ownCloud/coronavirus/variant_France/clean_code/conceptual_figure_gamma_distribution_", metascenario, ".pdf"), width = 4*figure_size_factor, height = 3*figure_size_factor)
par(mar = c(4,4,1,1))
plot(x, RW * dgamma(x, shape = MUW^2/SDW^2, scale = SDW^2/MUW), type = "l", xlab ="Days post infection", ylab = "Density", xaxs = "i", yaxs = "i", las = 1, lwd = 3, ylim = c(0, 0.25), bty = "n")
with(get_mutant_par(sc1), points(x, RV * dgamma(x, shape = shapeV, scale = scaleV), type = "l", col = cols[1], lwd = 3))
with(get_mutant_par(sc2), points(x, RV * dgamma(x, shape = shapeV, scale = scaleV), type = "l", col = cols[2], lwd = 3))
with(get_mutant_par(sc3), points(x, RV * dgamma(x, shape = shapeV, scale = scaleV), type = "l", col = cols[3], lwd = 3))
with(get_mutant_par(sc4), points(x, RV * dgamma(x, shape = shapeV, scale = scaleV), type = "l", col = cols[4], lwd = 3))
#if(metascenario==2)with(get_mutant_par(sc5), points(x, RV * dgamma(x, shape = shapeV, scale = scaleV), type = "l", col = cols[5], lwd = 3))
if(metascenario == 1) legend("topright", legend = mylegend, lwd = 3, col = c("black", cols), bty = "n")
dev.off()
# figure selection coefficient for the three scenarios:
Rfactor <- seq(0.1, 2, 0.01)
pdf(paste0("~/ownCloud/coronavirus/variant_France/clean_code/conceptual_figure_r_s_", metascenario, ".pdf"), width = 4*figure_size_factor, height = 1*figure_size_factor*3)
par(mar = c(4,4,1,1), mfrow= c(1,1))
#xlab <- expression(paste("Effective reproduction number ", R, " wild type"))
xlab <- expression(paste("Proxy for transmissibility ", R[H]))
plot(NULL, lty = 1, type = "l",
xlab = xlab, ylab = "Selection coefficient", xaxs = "i", yaxs = "i", las = 1, lwd = 3, ylim= c(-0.05, 0.1), xlim = c(0, 2), axes = F)
axis(side = 1, at = c(0, 0.5, 1, 1.5, 2))
axis(side = 2, at = c(-0.04, 0, 0.04, 0.08), las = 1)
#if(metascenario==2)
{
for(mys in c(0, 0.1, 0.2, 0.3, 0.4, 0.5)){
points(Rfactor * RW, y <- sapply(Rfactor, function(f) with(get_mutant_par(list(s1 = mys, s2 = 0, s3 = 0)), Rtor(R = f*RV, mu = MUV, SD = SDV)) - Rtor(R = f*RW, mu = MUW, SD = SDW)), col = "gray", lty = 1, type = "l", lwd = 1)
}
}
abline(h = 0, lty = 1)
points(Rfactor * RW, y <- sapply(Rfactor, function(f) with(get_mutant_par(sc1), Rtor(R = f*RV, mu = MUV, SD = SDV)) - Rtor(R = f*RW, mu = MUW, SD = SDW)), col = cols[1], lty = 1, type = "l", lwd = 3)
points(Rfactor * RW, y <- sapply(Rfactor, function(f) with(get_mutant_par(sc2), Rtor(R = f*RV, mu = MUV, SD = SDV)) - Rtor(R = f*RW, mu = MUW, SD = SDW)), col = cols[2], lty = 1, type = "l", lwd = 3)
points(Rfactor * RW, y <- sapply(Rfactor, function(f) with(get_mutant_par(sc3), Rtor(R = f*RV, mu = MUV, SD = SDV)) - Rtor(R = f*RW, mu = MUW, SD = SDW)), col = cols[3], lty = 1, type = "l", lwd = 3)
points(Rfactor * RW, y <- sapply(Rfactor, function(f) with(get_mutant_par(sc4), Rtor(R = f*RV, mu = MUV, SD = SDV)) - Rtor(R = f*RW, mu = MUW, SD = SDW)), col = cols[4], lty = 1, type = "l", lwd = 3)
#points(Rfactor * RW, y <- sapply(Rfactor, function(f) with(get_mutant_par(sc5), Rtor(R = f*RV, mu = MUV, SD = SDV)) - Rtor(R = f*RW, mu = MUW, SD = SDW)), col = cols[5], lty = 1, type = "l", lwd = 3)
text(x = rep(1.85, 6), y = c(0.003, 0.021, 0.04, 0.057, 0.073, 0.09), labels = c("WT", "+10%", "+20%", "+30%", "+40%", "+50%"), col = mygray)
dev.off()
pdf(paste0("~/ownCloud/coronavirus/variant_France/clean_code/conceptual_figure_r_r_", metascenario, ".pdf"), width = 4, height = 4)
par(mar = c(4,4,1,1), mfrow = c(1,1))
#xlab <- expression(paste("Effective reproduction number ", R, " wild type"))
plot(NULL, xlim = c(-0.5, 0.5), ylim = c(-0.5, 0.5), xlab = "Growth rate H (per week)", ylab = "Growth rate E (per week)", las = 1, bty = "n")
abline(h = 0, lty = 2, col = "gray")
abline(v = 0, lty = 2, col = "gray")
abline(0,1, col = "gray")
x1 <- 7*sapply(Rfactor, function(f) with(get_mutant_par(sc1), Rtor(R = f*RW, mu = MUW, SD = SDW)))
x2 <- 7*sapply(Rfactor, function(f) with(get_mutant_par(sc2), Rtor(R = f*RW, mu = MUW, SD = SDW)))
y1 <- 7*sapply(Rfactor, function(f) with(get_mutant_par(sc1), Rtor(R = f*RV, mu = MUV, SD = SDV)))
y2 <- 7*sapply(Rfactor, function(f) with(get_mutant_par(sc2), Rtor(R = f*RV, mu = MUV, SD = SDV)))
sub1 <- which(x1 > -0.5 & x1 < 0.5 & y1 > -0.5 & y1 < 0.5)
sub2 <- which(x2 > -0.5 & x2 < 0.5 & y2 > -0.5 & y2 < 0.5)
points(x1[sub1], y1[sub1], col = cols[1], lty = 1, type = "l", lwd = 3)
points(x2[sub2], y2[sub2], col = cols[2], lty = 1, type = "l", lwd = 3)
points(x = 7 * Rtor(R = 1/(1 + sc1$s1), mu = MUW, SD = SDW), y = 0, pch = 20, cex = 2)
#text(x = rep(1.85, 6), y = c(0.003, 0.021, 0.04, 0.057, 0.073, 0.09), labels = c("WT", "+10%", "+20%", "+30%", "+40%", "+50%"), col = mygray)
legend("bottomright", legend = c("Shorter mgt", "Longer mgt"), lwd = 3, col = c(cols[1:2]), bty = "n")
segments(x0 = x2[100], y0 = y2[100], x1 = x2[120], y1 = y2[100], lwd = 1.5, col = cols[2])
segments(x0 = x2[120], y0 = y2[100], x1 = x2[120], y1 = y2[120], lwd = 1.5, col = cols[2])
text(x = -0.2, y = 0.3, labels = expression(paste("Slope", phantom() %~~% phantom(), "1 + ", s[1], cv[H]^2, " - ", s[2])), col = cols[2])
dev.off()
######################################################################
##### epidemiological dynamics #####
######################################################################
R0H <- 2
max_time <- 80 # duration of simulations (we will eliminate ten days of burnin period to eliminate transient effects)
max_age <- 60 # following infections up to age max_age
begin_time <- 1
flag <- F; idx <- 1
while(flag){
R0vecH <- mvrnorm(n = 1, mu = rep(R0H, max_time), Sigma = create_BMautocov_mat(0.1, max_time = max_time))
if(mean(R0vecH[1:20]) > 1.5 & mean(R0vecH[(max_time-20):max_time]) < 0.95 & all(R0vecH > 0.)) flag <- F # select a realisation of BM where it is below 1 at the end
print(idx <- idx+1)
}
R0vecH <- c(2.1307553, 2.0105587, 2.0023232, 1.9215775, 1.9642554, 1.9238395, 2.1029669, 2.0780443, 2.1581173, 2.0758108, 2.1253340, 1.9948015, 1.8292173, 1.7309693, 1.7447241, 1.7712299, 1.7653672, 1.7129285, 1.8179133, 1.7841625, 1.9068882, 1.9366379, 2.0484530, 2.1590289, 2.1527725, 2.2736368, 2.2387613, 2.2257805, 2.1303752, 2.1895513, 2.2356056, 2.2355079, 2.3258214, 2.2258386, 2.1631581, 2.2186670, 2.1714491, 2.2069247, 2.1436307, 2.1366790, 2.0831706, 1.9912173, 1.8703819, 1.6309556, 1.4634919, 1.3115412, 1.1725386, 1.0649104, 1.0250046, 0.9133384, 1.0018016, 0.9228869, 0.9090948, 0.7077709, 0.5578058, 0.6371114, 0.7721366, 0.7062939, 0.6210061, 0.4607542, 0.5308621, 0.3945342, 0.4594047, 0.6524794, 0.6660125, 0.5297658, 0.5369410, 0.5645049, 0.6640699, 0.6662376, 0.5892468, 0.5752508, 0.7023259, 0.6168691, 0.4811847, 0.3900102, 0.4270968, 0.2734790, 0.3581384, 0.3733780)
plot(R0vecH, type = "l", las= 1, axes = F, xlab = "Time", ylab = expression(paste(R[0]))); abline(h = 1, lty = 2)
axis(side = 1, at = seq(0, 80, 20))
axis(side = 2, at = c(0.5, 1, 1.5, 2), las = 1)
# parameterise for IDF
pop_idf <- 12278210 # pop IDF
immunity_idf <- 0.2549 # estimation of immunity in IDF on 2021-01-01
sourceCpp("~/ownCloud/coronavirus/variant_France/clean_code/simulate_v2.cpp") # simulations in Rcpp
# tune parameters to value
pdf(paste0("~/ownCloud/coronavirus/variant_France/clean_code/conceptual_figure_evo_", metascenario, ".pdf"), width = 4*figure_size_factor2, height = 3*figure_size_factor2)
par(mar = c(4,4,1,1), mfrow = c(1,1))
plot(NULL, xlim = c(0, max_time), ylim = c(0, 1.), ylab = "Frequency of variants", xlab = "Time (days)", las = 1, xaxs = "i", yaxs = "i", axes = F)
# add the simulations with some transmissibility advtange:
ta_labels <- c("+10%", "+20%", "+30%", "+40%", "+50%")
names(ta_labels) <- seq(0.1, 0.5, 0.1)
# first the
for(transmission_advantage in seq(0.1, 0.5, 0.1)){
duration_advantage <- 0
sd_advantage <- 0
mycol <- "gray"
source("~/ownCloud/coronavirus/variant_France/clean_code/source_simulation_parameters.R")
sim <- simulate_Rcpp(
max_age = 60, # maximum age of infection to consider
initial_IW = 4000, # initial number of infected spread on each age (around 8000 infected per day in IDF if half are detected)
initial_IM = 400,
tmax = max_time, # maximum time (3 months)
simtlockdown = 50, # date of the lockdown (only when step function)
ifr = 0.0, # ifr
total_pop = pop_idf * (1 - immunity_idf), # for population immmunity - size of the population left to infect
par = c(
R0vecH,
0.5, # pdetection min
0.5, # pdetection max
1, # k time coefficient
100, # time mid-point for detection
transmission_advantage # transmission advantage
),
betafun = 3, # mode for beta function (smooth sigmoid or step function)
siW = siW, # generation time ("serial interval" distribution)
siM = siM, # generation time ("serial interval" distribution)
tid = tid, # time from infection to death
tit = tit # time from infection to test
)
f <- sim$all_detected_incidenceM/(sim$all_detected_incidenceW+sim$all_detected_incidenceM)
points(begin_time:max_time, f[begin_time:max_time], col = mycol, type = "l", lty = 1, pch = 20, lwd = 1)
text(75, (sim$all_detected_incidenceM/(sim$all_detected_incidenceW+sim$all_detected_incidenceM))[75], labels = ta_labels[as.character(transmission_advantage)], col = mygray)
}
all_epi_curves <- list()
for(scenar in 1:4){
transmission_advantage <- get(paste0("sc", scenar))$s1
duration_advantage <- get(paste0("sc", scenar))$s2
sd_advantage <- get(paste0("sc", scenar))$s3
mycol <- cols[scenar]
source("~/ownCloud/coronavirus/variant_France/clean_code/source_simulation_parameters.R")
sim <- simulate_Rcpp(
max_age = 60, # maximum age of infection to consider
initial_IW = 4000, # initial number of infected spread on each age (around 8000 infected per day in IDF if half are detected)
initial_IM = 400,
tmax = max_time, # maximum time (3 months)
simtlockdown = 50, # date of the lockdown (only when step function)
ifr = 0.0, # ifr
total_pop = pop_idf * (1 - immunity_idf), # for population immmunity - size of the population left to infect
par = c(
R0vecH,
0.5, # pdetection min
0.5, # pdetection max
1, # k time coefficient
100, # time mid-point for detection
transmission_advantage # transmission advantage
),
betafun = 3, # mode for beta function (smooth sigmoid or step function)
siW = siW, # generation time ("serial interval" distribution)
siM = siM, # generation time ("serial interval" distribution)
tid = tid, # time from infection to death
tit = tit # time from infection to test
)
# plot frequency dynamics:
f <- sim$all_detected_incidenceM/(sim$all_detected_incidenceW+sim$all_detected_incidenceM)
points(begin_time:max_time, f[begin_time:max_time], col = mycol, type = "l", pch = 20, lwd = 3, lty = 1) # frequency
#if(scenar == 1) legend("topleft", col = c("black", cols), legend = c("Wild Type cases", paste0("Variant cases - ", mylegend[2:5])), lty = 1, lwd = 2, bty = "n", cex = 0.5)
all_epi_curves[[scenar]] <- sim
}
axis(side = 1, at = seq(0, 80, 40))
axis(side = 2, at = seq(0, 1, 0.2), las = 1)
# add R0(t)
old_par <- par()
par(new = TRUE, mar=c(0,0,2,0), fig = c(0.22,0.48,0.7,1.)) # overlay existing plot
plot(R0vecH, type = "l", las= 1, lwd = 2, col = "black", col.main = "black", axes = F, xlab = "Time", main = expression(paste(R[0,WT](t))))
rect(par("usr")[1], par("usr")[3], par("usr")[2], par("usr")[4], col = "white", border = NA)
points(R0vecH, type = "l", lwd = 2, col = "black")
axis(side = 2, at = c(0.5, 1, 1.5, 2), las = 1)
axis(side = 1, at = seq(0, 80, 40), labels = rep("", 3))
suppressWarnings(par(old_par))
dev.off()
# now to the epidemiological figure
pdf(paste0("~/ownCloud/coronavirus/variant_France/clean_code/conceptual_figure_epi_", metascenario, ".pdf"), width = 4*figure_size_factor2, height = 3*figure_size_factor2)
par(mar = c(4,5,1,1), mfrow = c(1,1))
plot(NULL, xlim = c(0, max_time), ylim = c(0, 50000), ylab = "", xlab = "Time (days)", las = 1, xaxs = "i", yaxs = "i", axes = F)
title(ylab="Number of cases", line=4)
# cases per day:
for(scenar in 1:4){
mycol <- cols[scenar]
points(begin_time:max_time, all_epi_curves[[scenar]]$all_detected_incidenceM[begin_time:max_time] , col = mycol, type = "l", pch = 20, lwd = 3, lty = 1) # mutant incidence
points(begin_time:max_time, all_epi_curves[[scenar]]$all_detected_incidenceW[begin_time:max_time] , col = "black", type = "l", pch = 20, lwd = 3, lty = 1) # WT incidence
}
axis(side = 1, at = seq(0, 80, 40))
axis(side = 2, at = seq(0, 50000, 10000), las = 1)
if(metascenario == 1) legend("topleft", legend = mylegend, lwd = 3, col = c("black", cols), bty = "n")
dev.off()
}