# example_code.r # # This file provides an example on how to solve the evolutionary optimal strategy within # the adaptive model and evaluate it against the data on antidepressat purchases. # User can run the entire code by typing source("example_code.r") to the R command prompt, # but the working directory must contain the data file "SupplementaryData.txt". # # Tom Rosenstrom / 28.4.2016 ####################################################################################### ####### a function to solve the optimal strategy and MD prevalence around divorce ##### ####################################################################################### # Input values # action.strength refers to "s", the benefit from risky behavioral actions/mode u_1 # action.hazard refers to "z", the costs of risky behavioral actions/mode u_1 # errp = control parameter for the probability of erranous/random onset of mode u_0 or u_1 # noDecline=T allows user to study gradually declining fertility instead of constant fertility ModelEstimErr <- function(action.strength,action.hazard, errp=0.0005,noDecline=F,nOptim=F) { ######## Define model ####### ##### states ##### # x = 1 Seeking partner # x = 2 Reproduction possible # x = 3 Relationship at risk # x = 4 Dead ################## ##### actions #### # u = 0 normal behaviour # u = 1 risky/desperate ################## # ~1/8 of people die between ages 20-40 -> death rate ~0.0016 m <- 0.0016 ##### transitions probabilities if alive ##### # normal mode u_0 P0 <- matrix( c(1-0.028-m,0.028,0.0,m, 0.0,0.9-m,0.1,m, 1/10,1/10,8/10-m,m, 0,0,0,1), 4,4,byrow=T ) # risky mode u_1 P1 <- matrix( c(1-m-action.hazard,0.0,0.0,m+action.hazard, 0.0,0.9-m-action.hazard,0.1,action.hazard+m, 1/10-action.strength,1/10, 8/10+action.strength-action.hazard-m,m+action.hazard, 0,0,0,1), 4,4,byrow=T ) ##################################### # Direct reproductive value (RV) Boff <- function(x,Noffspring=0.25) { ifelse((x==2)|(x==3),Noffspring,0) } Boffs <- Boff(c(1:4)) # The terminal reward, i.e. RV at the final time period R <- c(0,0,0,0) # Derive optimal strategy tt <- seq(0,20*4,by=1) # 20 years divided to 3-month periods K <- length(tt) # for gradually declining fertility if (!noDecline) { # Backward recursion as in Houston & McNamara (1999), Models of Adaptive Behaviour: # An Approach Based on State. Cambridge University Press, UK. V <- matrix(0,4,length(tt)); V[,K] <- R strategy <- H0 <- H1 <- V for (i in 1:(K-1)) { H0[,K-i] <- Boffs*(1-(K-i)/K) + P0 %*% V[,K-i+1] H1[,K-i] <- Boffs*(1-(K-i)/K) + P1 %*% V[,K-i+1] tmp <- (H1[,K-i] - H0[,K-i]); strategy[,K-i] <- 1/(1+exp(-tmp/errp)) V[,K-i] <- (1-strategy[,K-i])*H0[,K-i] + strategy[,K-i]*H1[,K-i] } # for constant fertility } else { # Backward recursion as in Houston & McNamara (1999), Models of Adaptive Behaviour: # An Approach Based on State. Cambridge University Press, UK. V <- matrix(0,4,length(tt)); V[,K] <- Boffs strategy <- H0 <- H1 <- V for (i in 1:(K-1)) { H0[,K-i] <- Boffs + P0 %*% V[,K-i+1] H1[,K-i] <- Boffs + P1 %*% V[,K-i+1] tmp <- (H1[,K-i] - H0[,K-i]); strategy[,K-i] <- 1/(1+exp(-tmp/errp)) V[,K-i] <- (1-strategy[,K-i])*H0[,K-i] + strategy[,K-i]*H1[,K-i] } } # Having solved the optimal behavior, study prevalence of u_1 # in non-dead and around first 'divorce' by a simulation ######## simulate ######## N <- 50000 # individuals Ninits <- rmultinom(N,1,c(8/10,0.15,0.05,0)) # initial strategy prevalences # simulate the strategies that were used overall, given the small error in mode use res <- matrix(0,N,81) for (i in 1:N) { resj <- matrix(0,4,81); resj[,1] <- Ninits[,i] for (j in 1:80) { if (strategy[resj[,j]==1,j] > runif(1)) { resj[,j+1] <- rmultinom(1,1,t(P1) %*% resj[,j]) } else { resj[,j+1] <- rmultinom(1,1,t(P0) %*% resj[,j]) } } res[i,] <- apply(resj,2,function(x) which(x==1)) } # Solve the use of u_1 in divorce-centred time rather than ordinary time # Exclude 20 first and 20 last time periods to avoid boundary effects dd <- d <- rep(0,41) for (i in 1:N) { if (all(res[i,1:20]!=4)) { ind <- (res[i,1:80]==3)&(res[i,2:81]==1) # definition of divorce (transition x=3 -> x=1) divorce.time <- which(ind)[1]+1 if (any(ind)) { if ((divorce.time>20)&(divorce.time<60)) { if (all(res[i,divorce.time:(divorce.time+20)]!=4)) { for (j in 1:41) { d[j] <- strategy[res[i,(divorce.time-20):(divorce.time+20)][j], c((divorce.time-20):(divorce.time+20))[j]] } dd <- rbind(dd,d) } } } } } dd <- dd[2:nrow(dd),] # Return the prevalnce of u_1 in divorce-centred time for the user (tprevs <- colMeans(dd)) } ##################################################################### ############ Evaluate the model prediction against the data ######### ##################################################################### dd <- read.csv("SupplementaryData.csv") pd <- dd$Divorced # prevalence of antidepressant purchases among the divorced (centred time) time <- 1:41 pnd <- dd$nonDivorced # purchases prevalence for non divorced (ordinary time) # Detrend the prevalence for non-divorce related temporal trend bs <- summary(lm(pnd ~ time))$coefficients[,1] pd_detrended <- (pd - bs[1] - bs[2]*time) - min(pd - bs[1] - bs[2]*time) # Solve model prediction, g(t), using the above-defined function set.seed(2525) # use same seed for exact match with Table 1 tprevs <- ModelEstimErr(0.007,0.0024,noDecline=T) # Estimate nuisance parameters for purchases behaviour and maximum prevalence optimf_sa <- function(params) { du <- params[1]*dexp(0:41,rate=params[2]) tu <- convolve(tprevs[2:length(tprevs)],rev(du),type="open")[1:41] return(sum((pd_detrended-tu)^2)) } ores <- optim(c(0.12,0.1),optimf_sa) opar <- ores$par # Total prediction, (h * g)(t), with the estimated nuisance parameters contuse <- opar[1]*dexp(0:41,rate=opar[2]) sa.gt <- convolve(tprevs[2:length(tprevs)],rev(contuse),type="open")[1:41] # Model performance sse <- sum((pd_detrended-sa.gt)^2) sst <- sum((pd_detrended-mean(pd_detrended))^2) sa.R2 <- 1 - sse/sst print( paste( "R-squared = ", signif(sa.R2, 4) ) ) sa.AIC <- 2*2 + 41*log(sse) print( paste( "AIC = ",signif(sa.AIC, 5) ) ) sa.BIC <- 2*log(41) + 41*log(sse/41) print( paste( "BIC = ", signif(sa.BIC, 5) ) ) print("Estimated parameter values") sa.par <- ores$par; names(sa.par) <- c("alpha","lambda") print(sa.par) # Draw a figure of model-to-data fit plot(pd_detrended,ylim=c(-0.01,0.065),xaxt="n",ylab="Prevalence change",xlab="Month") lines(c(21,21),c(-0.05,0.07),lwd=2); lines(sa.gt,lwd=2); axis(1, at=c(1,10,21,31,41),labels=list('-60','-30','0','30','60')) legend(1,0.065,legend=c("Observation","Prediction"), title="Adaptive model",lty=c(NA,1,2),lwd=c(1,2,2),pch=c(1,NA,NA),bty="n",cex=0.9)