################################################################################################################################################## ## Code from Metcalf & Graham ## ## i) express survival mortality hazard as a function of specificity (/sensitivity as they are linked by a trade-off); ## ii) obtain derivative to identify optimal; ## iii) make matrix from which to extract 'sensitivities' in terms of change lambda ## iv) write out the run of scenarios to explore ## To see results run 'Figure1.landscapeSens()' or other functions starting with FigureXX ## ## Note that code and analysis is geared around 'specificity' for consistency with previous work (Metcalf, Tate & Graham, 2017, ## Nature Ecology and Evolution) but results are discussed in terms of 'sensitivity' as this is more intuitive. Conversion between the two ## is straightforward, with se = 1-exp(-gamma*(1-sp)) ## ################################################################################################################################################## ##' Survival at age x as a function of specificity and other parameters ##' ##' @param mu.b background mortality hazard ##' @param mu.i immunopathology hazard ##' @param mu.d disease hazard ##' @param mu.di immunopathology and disease hazard ##' @param sp specificity ##' @param gamma parameter governing the efficiency of discrimination (high values indicate more discrimination) ##' @param ix probability of infection ##' ##' @return numeric ##' sx <- function(mu.b,mu.i,mu.d,mu.di,sp=0.5, gamma=4, ix=0){ exp(-(mu.b+ mu.i*(1-sp)*(1-ix)+ mu.d*exp(-gamma*(1-sp))*ix+ mu.di*(1-exp(-gamma*(1-sp)))*ix)) } ##' Derivative of survival at age x as a function of specificity and other parameters ##' ##' @param mu.b background mortality hazard ##' @param mu.i immunopathology hazard ##' @param mu.d disease hazard ##' @param mu.di immunopathology and disease hazard ##' @param sp specificity ##' @param gamma parameter governing the efficiency of discrimination (high values indicate more discrimination) ##' @param ix probability of infection ##' ##' @return numeric ##' sx.prime <- function(mu.b,mu.i,mu.d,mu.di,sp=0.5, gamma=4, ix=0){ sx(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di,sp=sp, gamma=gamma, ix=ix)* ((1-ix)*mu.i- gamma*ix*mu.d*exp(-gamma*(1-sp))+ gamma*ix*mu.di*exp(-gamma*(1-sp))) } ##' Optimal specificity for a particular age ##' ##' @param mu.b background mortality hazard ##' @param mu.i immunopathology hazard ##' @param mu.d disease hazard ##' @param mu.di immunopathology and disease hazard ##' @param gamma parameter governing the efficiency of discrimination (high values indicate more discrimination) ##' @param ix probability of infection ##' ##' @return numeric sx.max <- function(mu.b,mu.i,mu.d,mu.di,gamma=4, ix=0){ 1+(1/gamma)*(log(mu.i/(mu.d-mu.di))+log(1/gamma)+log((1-ix)/ix)) } ##' Survivorship at age x, i.e., the product of survival at every age up to that age. ##' ##' @param mu.b background mortality hazard ##' @param mu.i immunopathology hazard ##' @param mu.d disease hazard ##' @param mu.di immunopathology and disease hazard ##' @param sp specificity ##' @param gamma parameter governing the efficiency of discrimination (high values indicate more discrimination) ##' @param ix vector of probability of infection at every age, here taking 60 age classes ##' ##' @return vector ##' lx <- function(mu.b,mu.i,mu.d,sp=0.5, gamma=4, ix=rep(0,60)) { prod(sx(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,sp=sp, gamma=gamma, ix=ix)) } ##' Derivative of survival at age x as a function of mu.d [here taking mu.i=exp(-eta*mu.d) and mu.di=rho*mu.i, see methods] ##' ##' @param mu.b background mortality hazard ##' @param mu.d disease hazard ##' @param sp specificity ##' @param eta parameter governing trade-off relationship between mu.d and mu.i ##' @param rho parameter governing magnitude of immunopathology during infection ##' @param gamma parameter governing the efficiency of discrimination (high values indicate more discrimination) ##' @param ix probability of infection ##' ##' @return numeric ##' sx.prime.mu.d <- function(mu.b,mu.d,sp,eta=30,rho=0.01,gamma=4, ix=0){ sx(mu.b=mu.b,mu.i=exp(-eta*mu.d),mu.d=mu.d,mu.di=rho*exp(-eta*mu.d),sp=sp, gamma=gamma, ix=ix)* (eta*(1-ix)*(1-sp)*exp(-eta*mu.d)- ix*exp(-gamma*(1-sp))+ eta*ix*rho*(1-exp(-gamma*(1-sp)))*exp(-eta*mu.d)) } ##' Optimal specificity for a particular age for mu.d ##' ##' @param mu.b background mortality hazard ##' @param sp specificity ##' @param eta parameter governing trade-off relationship between mu.d and mu.i ##' @param rho parameter governing magnitude of immunopathology during infection ##' @param gamma parameter governing the efficiency of discrimination (high values indicate more discrimination) ##' @param ix probability of infection ##' ##' @return numeric ##' sx.max.mu.d <- function(mu.b,sp,eta=30,rho=0.01,gamma=4, ix=0){ (1/eta)*(log(eta)+ log((1-ix)*(1-sp) +ix*rho*(1-exp(-gamma*(1-sp))))- log(ix*exp(-gamma*(1-sp)))) } ##' Make a Leslie matrix encompassing this probability of survival at every age ##' and with a chosen survival age trajectory ##' ##' @param mu.b background mortality hazard ##' @param mu.i immunopathology hazard ##' @param mu.d disease hazard ##' @param mu.di immunopathology and disease hazard ##' @param sp specificity ##' @param gamma parameter governing the efficiency of discrimination (high values indicate more discrimination) ##' @param ix a vector defining the probability of infection at each age - and note that its length defines the number of age classes ##' @param f.b a vector of fertility at every age, which should be the same length as ix ##' ##' @return list containing three vectors, survival only, fertility only, and the sum ##' makeMat <- function(mu.b,mu.i,mu.d,mu.di,sp=0.5, gamma, ix, f.b) { nage <- length(ix) U <- F <- matrix(0,nage,nage) F[1,] <- f.b psurv <- sx(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di,sp=sp, gamma=gamma, ix=ix) U[cbind(2:nage,1:(nage-1))] <- psurv[-length(psurv)] U[nage,nage] <- psurv[length(psurv)] return(list(U=U,F=F,M=U+F)) } ##' Sensitivity (and elasticitiy) of survival; as well as stable age and reproductive value from the Leslie matrix ##' ##' @param A - a matrix including both survival and fertiltiy transitions ##' ##' @return list survivalSens <- function(A){ lambda <- eigen(A)$values[1] w <- Re(eigen(A)$vectors[, 1]) v <- Re(eigen(t(A))$vectors[, 1]) vw <- sum(v * w) #the scalar product s <- outer(v, w) s <- s/vw s[A == 0] <- 0 ## set the 0s in matrix to 0 s[1,] <- 0 ## set to 0s for fertility matrix transitions to just get survival e <- s * A/lambda return(list(sensitivities = colSums(s), ##since 0s except in relevant col this should work elasticities = colSums(e), stable.age = w/sum(w), repro.value = v/v[1])) } ##' Sensitivity (and elasticitiy) of fertility; as well as stable age and reproductive value ##' ##' @param A - a matrix including both survival and fertiltiy transitions ##' ##' @return list fertilitySens <- function(A){ lambda <- eigen(A)$values[1] w <- Re(eigen(A)$vectors[, 1]) v <- Re(eigen(t(A))$vectors[, 1]) vw <- sum(v * w) #the scalar product s <- outer(v, w) s <- s/vw s[A == 0] <- 0 ## set the 0s in matrix to 0 s[2:nrow(s),] <- 0 ## set all of the matrix to zero, except first row to focus on fertiltiy e <- s * A/lambda return(list(sensitivities = colSums(s), ##since 0s except in relevant col this should work elasticities = colSums(e), stable.age = w/sum(w), repro.value = v/v[1])) } ##' Define table of scenarios of interest underpinning Figure 3; ##' ##' @param sp specificity ##' @param gamma discrimination ##' @param nage number of age classes to model ##' @param age.maturity the age at which fertility begins ##' ##' @return list including relevant output for the different scenarios scenarios <- function(sp=0.5, gamma=4,nage=40, age.maturity=5){ # Storage lam <- rep(NA,6) opt.sp.age <- sens <- w <- v <- surv.age <- matrix(NA,6,nage) gamma <- 4 se <- 1-exp(-gamma*(1-sp)) #Flat fertility fert <- rep(0,nage) fert[age.maturity:nage] <- 1 #Flat background mortality mu.b <- rep(1/60,nage) mu.i <- rep(0.05,nage) #mu.i <- rep(0.002,nage) #mu.d <- rep(0.2,nage) mu.d <- rep(1,nage) mu.di <- rep(0.001,nage) ix <- rep(0.02,nage) ## 1. Basline case M1 <- makeMat(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di,sp=sp, gamma=gamma, ix=ix, f.b=fert) svals <- survivalSens(M1$M) lam[1] <- Re(eigen(M1$M)$values[1]) w[1,] <-svals$stable.age v[1,] <-svals$repro.value sens[1,] <- svals$sensitivities opt.sp.age[1,] <- sx.max(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di, gamma=gamma, ix=ix) surv.age[1,] <- colSums(M1$U) #Add female risk during pregnancy mu.b[age.maturity:nage] <- mu.b[age.maturity:nage]*20#1.1 ## 2. Female preg risk M1 <- makeMat(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di,sp=sp, gamma=gamma, ix=ix, f.b=fert) svals <- survivalSens(M1$M) lam[2] <- Re(eigen(M1$M)$values[1]) w[2,] <-svals$stable.age v[2,] <-svals$repro.value sens[2,] <- svals$sensitivities opt.sp.age[2,] <- sx.max(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di, gamma=gamma, ix=ix) surv.age[2,] <- colSums(M1$U) ## reset mu.b[age.maturity:nage] <- mu.b[1] #Add female risk infection during pregnancy ix[age.maturity:nage] <- ix[age.maturity:nage]*5#2 ## 3. Female preg risk + risk infection higher M1 <- makeMat(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di,sp=sp, gamma=gamma, ix=ix, f.b=fert) svals <- survivalSens(M1$M) lam[3] <- Re(eigen(M1$M)$values[1]) w[3,] <-svals$stable.age v[3,] <-svals$repro.value sens[3,] <- svals$sensitivities opt.sp.age[3,] <- sx.max(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di, gamma=gamma, ix=ix) surv.age[3,] <- colSums(M1$U) ## reset ix[age.maturity:nage] <- ix[1] #Add female risk mortality during infection pregnancy mu.d[age.maturity:nage] <- mu.d[age.maturity:nage]*20#1.2 ## 4. Female preg risk + risk infection higher + risk mort during infection higher M1 <- makeMat(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di,sp=sp, gamma=gamma, ix=ix, f.b=fert) svals <- survivalSens(M1$M) lam[4] <- Re(eigen(M1$M)$values[1]) w[4,] <-svals$stable.age v[4,] <-svals$repro.value sens[4,] <- svals$sensitivities opt.sp.age[4,] <- sx.max(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d, mu.di=mu.di,gamma=gamma, ix=ix) surv.age[4,] <- colSums(M1$U) ## reset mu.d[age.maturity:nage] <- mu.d[1] #Add female risk miscarriage (must decline with sensitivity) fert <- rep(0,nage) fert[age.maturity:nage] <- exp(-(0.1*se)) ## 5. Female miscarriage M1 <- makeMat(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di,sp=sp, gamma=gamma, ix=ix, f.b=fert) svals <- survivalSens(M1$M) lam[5] <- Re(eigen(M1$M)$values[1]) w[5,] <-svals$stable.age v[5,] <-svals$repro.value sens[5,] <- svals$sensitivities opt.sp.age[5,] <- sx.max(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di, gamma=gamma, ix=ix) surv.age[5,] <- colSums(M1$U) #print(fert) #Add breeding monopoly fert <- rep(0,nage) fert[age.maturity:nage] <- seq(1,2,length=length(age.maturity:nage)) #print(fert) ## 6. Female later breeding monopoly (removed the effect of miscarriage here) M1 <- makeMat(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di,sp=sp, gamma=gamma, ix=ix, f.b=fert) svals <- survivalSens(M1$M) lam[6] <- Re(eigen(M1$M)$values[1]) w[6,] <-svals$stable.age v[6,] <-svals$repro.value sens[6,] <- svals$sensitivities opt.sp.age[6,] <- sx.max(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di, gamma=gamma, ix=ix) surv.age[6,] <- colSums(M1$U) scenario.names <- c("baseline","+ more mortality during pregnancy", ## change mu.b "+ more infection during pregnancy", ## change ix "+ more dangerous infection during pregnancy", ## change mu.d "+ risk miscarriage with se", ## change fert "+ monopoly older") ##note last one cancels out miscarriage return(list(lam=lam,w=w,v=v, sens=sens,opt.sp.age=opt.sp.age,surv.age=surv.age, scenario.names=scenario.names)) } ##' Define table of scenarios of interest, but now allowing infection to vary (Figure S3 and Figure S4) ##' ##' @param ix age profiles of infection ##' @param fertility age profile fertility ##' @param sp specificity ##' @param gamma discrimination ##' @param nage number of age classes to model ##' @param age.maturity the age at which fertility begins ##' ##' @return list including relevant output for the different scenarios scenarios.ix.vary <- function(ix=rep(0.1,40),fert=rep(1,40), sp=0.5,gamma=4, nage=40, age.maturity=5){ # Storage lam <- rep(NA,2) opt.sp.age <- sens <- w <- v <- surv.age <- matrix(NA,2,nage) # Get sens se <- 1-exp(-gamma*(1-sp)) #Flat background mortality mu.b <- rep(1/60,nage) mu.i <- rep(0.05,nage) mu.d <- rep(1,nage) mu.di <- rep(0.001,nage) ## 1. Basline case M1 <- makeMat(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di,sp=sp, gamma=gamma, ix=ix, f.b=fert) svals <- survivalSens(M1$M) lam[1] <- Re(eigen(M1$M)$values[1]) w[1,] <-svals$stable.age v[1,] <-svals$repro.value sens[1,] <- svals$sensitivities opt.sp.age[1,] <- sx.max(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di, gamma=gamma, ix=ix) surv.age[1,] <- colSums(M1$U) #Add female risk during pregnancy mu.b[age.maturity:nage] <- mu.b[age.maturity:nage]*20#1.1 ## 2. Female preg risk M1 <- makeMat(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di,sp=sp, gamma=gamma, ix=ix, f.b=fert) svals <- survivalSens(M1$M) lam[2] <- Re(eigen(M1$M)$values[1]) w[2,] <-svals$stable.age v[2,] <-svals$repro.value sens[2,] <- svals$sensitivities opt.sp.age[2,] <- sx.max(mu.b=mu.b,mu.i=mu.i,mu.d=mu.d,mu.di=mu.di, gamma=gamma, ix=ix) surv.age[2,] <- colSums(M1$U) ## reset mu.b[age.maturity:nage] <- mu.b[1] scenario.names <- c("baseline","+ more mortality during pregnancy") return(list(lam=lam,w=w,v=v, sens=sens,opt.sp.age=opt.sp.age,surv.age=surv.age, scenario.names=scenario.names)) } ##' Test the effect of the shape of the tradeoff linking immunopathology and disease damage ##' ##' @param gamma governs discrimination ##' @param zeta governs relationship between mu.d and mu.id, ##' now taken as linear, according to int-zeta*mu.d.test (the intercept set to constrain to be positive, in this example =5) ##' ##' @return nothing, just makes a picture testShapeTradeOff <- function(gamma=4,zeta=0.8){ # Range for test se.test <- seq(0.01,0.99,length=100) sp.test <- 1-log(1-se.test)/(-gamma) mu.d.test <- seq(0.01,4,length=100) ## pick an intercept to constrain mu.i to be positive int <- 4 print("Range mu.i") print(range(int-zeta*mu.d.test)) # Storage surv.x <- matrix(NA,length(mu.d.test),length(sp.test)) # Baseline mu.b <- 1/60 ix <- 0.5 rho <- 0.01 # Loop for (j in 1:length(sp.test)) { for (k in 1:length(mu.d.test)) { surv.x[k,j] <- sx(mu.b=mu.b,mu.i=int-zeta*mu.d.test[k],mu.d=mu.d.test[k], mu.di=rho*(int-zeta*mu.d.test[k]),sp=sp.test[j], gamma=gamma, ix=ix) }} par(mfrow=c(1,1),pty="s") cols <- colorRampPalette(c(rgb(1,0,0,1), rgb(1,0,0,0)), alpha = TRUE)(20) image(mu.d.test,se.test,surv.x,col=cols, ylab=expression("Sensitivity, "*s[e]),xlab=expression("Hazard of infection, "*mu[d])) contour(mu.d.test,se.test,surv.x, add=TRUE) } ############################################################################################### ##' Make landscape of survival across sensitivity; ##' ##' @param gamma discrimination ##' @param eta parameter governing trade-off relationship between mu.d and mu.i ##' @param do.FigS2 boolean stating whether Figure S2 should also be shown ##' ##' @return nothing, makes plots Figure1.landscapeSens <- function(gamma=4,eta=0.8, do.FigS2=FALSE){ # Range for test se.test <- seq(0.01,0.99,length=100) sp.test <- 1-log(1-se.test)/(-gamma) mu.d.test <- seq(0.01,4,length=100) # Storage surv.x.lowi <- surv.x.highi <- surv.x <- matrix(NA,length(mu.d.test),length(sp.test)) # Baseline mu.b <- 1/60 ix <- 0.5 rho <- 0.01 # Loop for (j in 1:length(sp.test)) { for (k in 1:length(mu.d.test)) { surv.x[k,j] <- sx(mu.b=mu.b,mu.i=exp(-eta*mu.d.test[k]),mu.d=mu.d.test[k], mu.di=rho*exp(-eta*mu.d.test[k]),sp=sp.test[j], gamma=gamma, ix=ix) surv.x.lowi[k,j] <- sx(mu.b=mu.b,mu.i=exp(-eta*mu.d.test[k]),mu.d=mu.d.test[k], mu.di=rho*exp(-eta*mu.d.test[k]),sp=sp.test[j], gamma=gamma, ix=0.1) surv.x.highi[k,j] <- sx(mu.b=mu.b,mu.i=exp(-eta*mu.d.test[k]),mu.d=mu.d.test[k], mu.di=rho*exp(-eta*mu.d.test[k]),sp=sp.test[j], gamma=gamma, ix=0.9) }} par(mfrow=c(1,1),pty="s") cols <- colorRampPalette(c(rgb(1,0,0,1), rgb(1,0,0,0)), alpha = TRUE)(20) image(mu.d.test,se.test,surv.x,col=cols, ylab=expression("Sensitivity, "*s[e]),xlab=expression("Hazard of infection, "*mu[d])) contour(mu.d.test,se.test,surv.x, add=TRUE) ## And as a bonus, Figure S1 if (do.FigS2) { par(mfrow=c(1,3),pty="s") cols <- colorRampPalette(c(rgb(1,0,0,1), rgb(1,0,0,0)), alpha = TRUE)(20) image(mu.d.test,se.test,surv.x.lowi,col=cols, ylab=expression("Sensitivity, "*s[e]),xlab=expression("Hazard of infection, "*mu[d])) contour(mu.d.test,se.test,surv.x.lowi, add=TRUE) image(mu.d.test,se.test,surv.x,col=cols, ylab=expression("Sensitivity, "*s[e]),xlab=expression("Hazard of infection, "*mu[d])) contour(mu.d.test,se.test,surv.x, add=TRUE) image(mu.d.test,se.test,surv.x.highi,col=cols, ylab=expression("Sensitivity, "*s[e]),xlab=expression("Hazard of infection, "*mu[d])) contour(mu.d.test,se.test,surv.x.highi, add=TRUE) } } ##' Function to plot Figure 2 ##' ##' @param none - but you can change the defaults within the function if curious ##' ##' @return nothing, but makes a plot Figure2.scenarios <- function(){ nage <- 40 ## this is set in the function age.maturity <- 10 gamma <- 4 sp.test <- seq(0,0.99,length=100) se.test <- 1-exp(-gamma*(1-sp.test)) lam <- matrix(NA,6,length(sp.test)) surv.age <- opt.sp.age <- w <- v <- sens <- array(dim=c(6,length(sp.test),nage)) for (j in 1:length(sp.test)) { tmp <- scenarios(sp=sp.test[j],gamma=gamma, nage=nage, age.maturity=age.maturity) lam[,j] <- tmp$lam w[,j,] <- tmp$w v[,j,] <- tmp$v sens[,j,] <- tmp$sens opt.sp.age[,j,] <- tmp$opt.sp.age surv.age[,j,] <- tmp$surv.age } #find optimals index.opt <- opt <- rep(NA,6) for (k in 1:6) { index.opt[k] <- median(which(lam[k,]==max(lam[k,],na.rm=TRUE),arr.ind=TRUE)) opt[k] <- sp.test[index.opt[k]] } #conver to se opt.se <- 1-exp(-gamma*(1-opt)) ## plot the sensitivity etc NOT at the optimal but all at same value -> easier to compare to.plot <- floor(length(sp.test)/2) ## Single plots require(RColorBrewer) cols <- brewer.pal(7,'Set1') cols[6] <- cols[7] cols <- c("black",cols) ltys <- c(1,1,1,1,1,1) max.x <- 30 #par(mfrow=c(2,4), bty="l",pty="m", mar=c(5,4,2,2)) par(mfrow=c(2,4), bty="l",pty="m", mar=c(4,4,1.5,2)) ##xj plot(1:nage,surv.age[k,to.plot,], xlab="Age", ylab=expression("Probability of survival, "*s[x]),xlim=c(0,max.x), type="n", pch=19, ylim=range(c(0.6,surv.age[,to.plot,],na.rm=TRUE))) legend("topright",legend="A)",bty="n", cex=0.8) abline(v=age.maturity, col="grey") for (k in 1:4) { points(1:nage,surv.age[k,to.plot,], type="l", pch=19, col=cols[k],lty=ltys[k])} plot(1:nage,w[k,to.plot,], xlab="Age", ylab=expression("Stable age structure, "*w[x]), type="n",xlim=c(0,max.x), pch=19, ylim=range(w[,to.plot,],na.rm=TRUE))#, log="y") legend("topright",legend="B)",bty="n", cex=0.8) abline(v=age.maturity, col="grey") for (k in 1:4) { points(1:nage,w[k,to.plot,], type="l", pch=19,col=cols[k],lty=ltys[k])} plot(1:nage,v[k,to.plot,], xlab="Age", ylab=expression("Reproductive value, "*v[x]), type="n", xlim=c(0,max.x), pch=19, ylim=range(v[,to.plot,],na.rm=TRUE)) legend("topright",legend="C)",bty="n", cex=0.8) abline(v=age.maturity, col="grey") for (k in 1:6) { points(1:nage,v[k,to.plot,], type="l", pch=19, col=cols[k],lty=ltys[k])} plot(1:nage,sens[k,to.plot,], xlab="Age", ylab=expression(delta*lambda*"/"*delta*s[x]), type="n",xlim=c(0,max.x), pch=19, ylim=range(sens[,to.plot,],na.rm=TRUE)) legend("topright",legend="D)",bty="n", cex=0.8) abline(v=age.maturity, col="grey") for (k in 1:6) { points(1:nage,sens[k,to.plot,], type="l", pch=19,col=cols[k],lty=ltys[k])} sp.delta.lam.plot <- 61 for (k in 2:6) { if (k<6) plot(se.test,lam[1,], xlab=expression("Sensitivity, "*s[e]), ylab=expression(lambda), ylim=pmax(range(lam,na.rm=TRUE),1.06), type="l",col=cols[1], xlim=c(0,1)) points(opt.se[1],max(lam[1,],na.rm=TRUE),pch=19,col=cols[1]) abline(v=opt.se[1], col=cols[1]) #add layers points(se.test,lam[k,],type="l",col=cols[k],lty=ltys[k]) abline(v=opt.se[k], col=cols[k]) points(opt.se[k],max(lam[k,],na.rm=TRUE),pch=19,col=cols[k]) if (k==2) legend("topright",legend="E)",bty="n", cex=0.8) if (k==3) legend("topright",legend="F)",bty="n", cex=0.8) if (k==4) legend("topright",legend="G)",bty="n", cex=0.8) if (k==5) legend("topright",legend="H)",bty="n", cex=0.8) } } ##' Function to plot Figures S3 and S4, illustrates that with a balance of infection over age, you can end up ## with JUST changing mu.b or fert having an effect on the optimal ##' ##' @param none - but you can change the defaults within the function if curious ##' ##' @return nothing, but makes a plot FigureS3.S4.AgeInfectionEffect <- function(){ nage <- 40 age.maturity <- 15 gamma <- 4 sp.test <- seq(0,0.99,length=100) se.test <- 1-exp(-gamma*(1-sp.test)) ## storage lam <- matrix(NA,2,length(sp.test)) surv.age <- opt.sp.age <- w <- v <- sens <- array(dim=c(2,length(sp.test),nage)) ## for increased fertlity lam.f <- matrix(NA,2,length(sp.test)) surv.age.f <- opt.sp.age.f <- w.f <- v.f <- sens.f <- array(dim=c(2,length(sp.test),nage)) ##put together a range of infected ix <- matrix(0,20,nage) #for (j in 1:nrow(ix)) ix[j,] <- dbinom(1:nage,j*5,0.2) for (j in 1:nrow(ix)) ix[j,] <- dnorm(1:nage,j,3) ix <- (nage/50)*ix/rowSums(ix) ix <- pmin(pmax(ix,0.001),0.99) opt.store <- opt.f.store <- matrix(NA,nrow(ix),2) ## which ones to put on the plot choose.plot <- c(3,15,20) #layout(matrix(c(1,3,5,6,2,4,5,6,7,9,11,12,8,10,11,12,13,15,17,18,14,16,17,18),6,4, byrow=TRUE)) layout(matrix(c(1,3,4,5,6,2,3,4,5,6,7,9,10,11,12,8,9,10,11,12,13,15,16,17,18,14,15,16,17,18),6,5, byrow=TRUE)) for (jj in 1:nrow(ix)) { for (j in 1:length(sp.test)) { ## Flat fertility fert <- rep(0,nage) fert[age.maturity:nage] <- 1 tmp <- scenarios.ix.vary(ix=ix[jj,],sp=sp.test[j],gamma=gamma, fert=fert, nage=nage, age.maturity=age.maturity) lam[,j] <- tmp$lam w[,j,] <- tmp$w v[,j,] <- tmp$v sens[,j,] <- tmp$sens opt.sp.age[,j,] <- tmp$opt.sp.age surv.age[,j,] <- tmp$surv.age ## Increasing fertility fert <- rep(0,nage) fert[age.maturity:nage] <- exp(seq(1,10,length=length(age.maturity:nage))) tmp <- scenarios.ix.vary(ix=ix[jj,],sp=sp.test[j],gamma=gamma, fert=fert, nage=nage, age.maturity=age.maturity) lam.f[,j] <- tmp$lam w.f[,j,] <- tmp$w v.f[,j,] <- tmp$v sens.f[,j,] <- tmp$sens opt.sp.age.f[,j,] <- tmp$opt.sp.age surv.age.f[,j,] <- tmp$surv.age } #find optimals index.opt <- opt <- index.opt.f <- opt.f <- rep(NA,2) for (k in 1:2) { index.opt[k] <- median(which(lam[k,]==max(lam[k,],na.rm=TRUE),arr.ind=TRUE)) opt[k] <- sp.test[index.opt[k]] index.opt.f[k] <- median(which(lam.f[k,]==max(lam.f[k,],na.rm=TRUE),arr.ind=TRUE)) opt.f[k] <- sp.test[index.opt.f[k]] ##store as sensitivities opt.store[jj,k] <- 1-exp(-gamma*(1-opt[k])) opt.f.store[jj,k] <- 1-exp(-gamma*(1-opt.f[k])) } #conver to se opt.se <- 1-exp(-gamma*(1-opt)) opt.se.f <- 1-exp(-gamma*(1-opt.f)) ## plot the sensitivity etc NOT at the optimal but all at same value -> easier to compare to.plot <- floor(length(sp.test)/2) if (sum(jj==choose.plot)>0) { ## Single plots require(RColorBrewer) cols <- brewer.pal(7,'Set1') cols <- c("black",cols) max.x <- 30 cex.lab <- 0.7 ltys <- 3 par(mar=c(3.2,4,1,2)) plot(1:nage,ix[jj,], type="l",xlab="", ylab=expression("Prob. infection, "*i[x]),xlim=c(0,max.x), ylim=range(ix), cex.lab=cex.lab) par(mar=c(4.2,4,0,2)) plot(1:nage,surv.age[k,to.plot,], xlab="Age", ylab=expression("Prob. surv, "*s[x]),xlim=c(0,max.x), cex.lab=cex.lab, type="n", pch=19, ylim=range(c(0.5,surv.age[,to.plot,],na.rm=TRUE))) abline(v=age.maturity, col="grey") for (k in 1:2) { points(1:nage,surv.age[k,to.plot,], type="l", pch=19, col=cols[k],lty=1)} for (k in 1:2) { points(1:nage,surv.age.f[k,to.plot,], type="l", pch=19, col=cols[k],lty=2)} par(mar=c(4,4,2,2)) plot(1:nage,w[k,to.plot,], xlab="Age", ylab=expression("Stable age structure, "*w[x]), type="n",xlim=c(0,max.x), #cex.lab=cex.lab, pch=19, ylim=range(c(c(w[,to.plot,1:max.x]),c(w.f[,to.plot,1:max.x])),na.rm=TRUE))#, log="y") abline(v=age.maturity, col="grey") for (k in 1:2) { points(1:nage,w[k,to.plot,], type="l", pch=19,col=cols[k],lty=1)} for (k in 1:2) { points(1:nage,w.f[k,to.plot,], type="l", pch=19,col=cols[k],lty=3)} plot(1:nage,v[k,to.plot,], xlab="Age", ylab=expression("Reproductive value, "*v[x]), type="n", xlim=c(0,max.x), #cex.lab=cex.lab, pch=19, ylim=range(c(c(v[,to.plot,1:max.x]),c(v.f[,to.plot,1:max.x])),na.rm=TRUE), log="y") abline(v=age.maturity, col="grey") for (k in 1:2) { points(1:nage,v[k,to.plot,], type="l", pch=19, col=cols[k],lty=1)} for (k in 1:2) { points(1:nage,v.f[k,to.plot,], type="l", pch=19, col=cols[k],lty=3)} plot(1:nage,sens[k,to.plot,], xlab="Age", ylab=expression(delta*lambda*"/"*delta*s[x]), type="n",xlim=c(0,max.x), #cex.lab=cex.lab, pch=19, ylim=range(c(c(sens[,to.plot,1:max.x]),c(sens.f[,to.plot,1:max.x])),na.rm=TRUE)*c(1,1.1)) abline(v=age.maturity, col="grey") for (k in 1:2) { points(1:nage,sens[k,to.plot,], type="l", pch=19,col=cols[k],lty=1)} for (k in 1:2) { points(1:nage,sens.f[k,to.plot,], type="l", pch=19,col=cols[k],lty=3)} sp.delta.lam.plot <- 61 plot(se.test,lam[1,], xlab=expression("Sensitivity, "*s[e]), ylab=expression(lambda), #cex.lab=cex.lab, ylim=range(c(c(lam),c(lam.f)),na.rm=TRUE)*c(1,1.05), type="l", col=cols[1])#, xlim=c(0.01,0.99)) points(se.test,lam.f[1,], type="l",lty=3) points(opt.se[1],max(lam[1,],na.rm=TRUE),pch=19,col=cols[1]) points(opt.se.f[1],max(lam.f[1,],na.rm=TRUE),pch=19,col=cols[1]) abline(v=opt.se[1], col=cols[1]) abline(v=opt.se.f[1], col=cols[1], lty=3) #add layers k <- 2 points(se.test,lam[k,],type="l",col=cols[k],lty=1) abline(v=opt.se[k], col=cols[k]) points(opt.se[k],max(lam[k,],na.rm=TRUE),pch=19,col=cols[k]) points(se.test,lam.f[k,],type="l",col=cols[k],lty=3) abline(v=opt.se.f[k], col=cols[k], lty=3) points(opt.se.f[k],max(lam.f[k,],na.rm=TRUE),pch=19,col=cols[k]) } } par(mfrow=c(1,1),bty="l",pty="s") plot(opt.store[,1],xlab="Average age of infection", ylab=expression("Optimal sensitivity, "*s[e]), type="b",pch=19, ylim=c(0,1), cex=0.8) points(opt.store[,2],type="b",pch=19,col=2, cex=0.8) points(opt.f.store[,1],type="b",pch=15,col=1, lty=3, cex=0.8) points(opt.f.store[,2],type="b",pch=15,col=2, lty=3, cex=0.8) abline(v=age.maturity, col="grey") legend("bottomleft",legend=c("Baseline", "Increased mortality, childbearing years", "Baseline + increased fertility over age", "Increased fertility over age + increased mortality, childbearing years"), lty=c(1,1,3,3),col=c(1,2,1,2),cex=0.8,pch=c(19,19,15,15), bty="n") return(list(opt.store=opt.store,opt.f.store=opt.f.store, ix=ix)) }