rm(list=ls()) ##### OPEN R LIBRARIES and Set WD ##### library(fitdistrplus) library(popbio) # package for solving projection matrix ##### INITIALIZE VARIABLES ###### F <- 1 # Management objective theta <- 1 # Form of density dependence (1 = linear) n.iter <- 10000 # Number of iterations ##### CREATE EMPTY ARRAYS AND DATA FRAMES ##### cs.mat <- matrix(0,nrow=n.iter,ncol=2) N.mat <- matrix(0,nrow=n.iter,ncol=2) recruit.mat <- matrix(0,nrow=n.iter,ncol=2) recruit <- array() # Recruitment based on age ratios N <- array() # Fall flight cs <- array() K <- array() # Kill (H/(1-c)): Numbers of birds dv <- array() project.mat.r <- array() # r-max from projection matrix project.mat.h <- array() # Max allowable harvest rate: from projection matrix H.projmat <- array() # Max allowable total harvest (hmax*BPOP): from projection matrix projmatcomp <- array() # Comparison of H.max to K.obs: from projection matrix HAminusHRprojmat <- array() # Used for sensitivity analysis #------------------------------------ Create Distributions From Expert Elicitation ------------------------------------------# # Fall flight example with two experts fallflight.1 <-c(350000,450000,550000,80) half.probFF.1 <- (1-(fallflight.1[4]/100))/2 est.fallflight.1 <- qmedist(fallflight.1[1:3],"lnorm",probs=c((0+half.probFF.1),(1-half.probFF.1))) parms.fallflight.1 <- est.fallflight.1$estimate N.mat[,1] <- rlnorm(n.iter,parms.fallflight.1[1],parms.fallflight.1[2]) fallflight.2 <-c(230000,265000,285000,60) half.probFF.2 <- (1-(fallflight.2[4]/100))/2 est.fallflight.2 <- qmedist(fallflight.2[1:3],"lnorm",probs=c((0+half.probFF.2),(1-half.probFF.2))) parms.fallflight.2 <- est.fallflight.2$estimate N.mat[,2] <- rlnorm(n.iter,parms.fallflight.2[1],parms.fallflight.2[2]) # Breeding propensity for Adults (proportion of adults that breed) breedpradl <-c(0.85,0.9,0.95,70) half.probBP <- (1-(breedpradl[4]/100))/2 est.breedpradl <- qmedist(breedpradl[1:3],"beta",probs=c((0+half.probBP),(1-half.probBP))) parms.breedpradl <- est.breedpradl$estimate bp.ad <- rbeta(n.iter,parms.breedpradl[1],parms.breedpradl[2]) # First- year survival (from fledging to the following spring) firstsurv <-c(0.6,0.7,0.8,50) half.probp1 <- (1-(firstsurv[4]/100))/2 est.firstsurv <- qmedist(firstsurv[1:3],"beta",probs=c((0+half.probp1),(1-half.probp1))) parms.firstsurv <- est.firstsurv$estimate p1 <- rbeta(n.iter,parms.firstsurv[1],parms.firstsurv[2]) # second-year survival seconsurv <-c(0.75,0.8,0.95,60) half.probp2 <- (1-(seconsurv[4]/100))/2 est.seconsurv <- qmedist(seconsurv[1:3],"beta",probs=c((0+half.probp2),(1-half.probp2))) parms.seconsurv <- est.seconsurv$estimate p2 <- rbeta(n.iter,parms.seconsurv[1],parms.seconsurv[2]) # Adult survival adultsurv <-c(0.85,0.9,0.95,60) half.probp.ad <- (1-(adultsurv[4]/100))/2 est.adultsurv <- qmedist(adultsurv[1:3],"beta",probs=c((0+half.probp.ad),(1-half.probp.ad))) parms.adultsurv <- est.adultsurv$estimate p.ad <- rbeta(n.iter,parms.adultsurv[1],parms.adultsurv[2]) # Probability that birds first breed at 2 years pfirstbr.2 <- rbinom(n.iter,100,0.2)/100 # Clutch size clutchsize <-c(7.5,8.5,9.5,90) half.probcs <- (1-(clutchsize[4]/100))/2 est.clutchsize <- qmedist(clutchsize[1:3],"lnorm",probs=c((0+half.probcs),(1-half.probcs))) parms.clutchsize <- est.clutchsize$estimate cs.mat[,1] <- rlnorm(n.iter,parms.clutchsize[1],parms.clutchsize[2]) # Nesting success nestsucc <-c(0.4,0.6,0.7,60) half.probns <- (1-(nestsucc[4]/100))/2 est.nestsucc <- qmedist(nestsucc[1:3],"beta",probs=c((0+half.probns),(1-half.probns))) parms.nestsucc <- est.nestsucc$estimate ns <- rbeta(n.iter,parms.nestsucc[1],parms.nestsucc[2]) # Hatching success hatchsucc <-c(0.6,0.85,0.9,60) half.probhs <- (1-(hatchsucc[4]/100))/2 est.hatchsucc <- qmedist(hatchsucc[1:3],"beta",probs=c((0+half.probhs),(1-half.probhs))) parms.hatchsucc <- est.hatchsucc$estimate hs <- rbeta(n.iter,parms.hatchsucc[1],parms.hatchsucc[2]) # Duckling survival from hatching to fledging ducksurv <-c(0.2,0.4,0.6,50) half.probds <- (1-(ducksurv[4]/100))/2 est.ducksurv <- qmedist(ducksurv[1:3],"beta",probs=c((0+half.probds),(1-half.probds))) parms.ducksurv <- est.ducksurv$estimate ds <- rbeta(n.iter,parms.ducksurv[1],parms.ducksurv[2]) # DV diff.v <-c(1.5,2.5,3.5,95) half.probdv <- (1-(diff.v[4]/100))/2 est.dv <- qmedist(diff.v[1:3],"lnorm",probs=c((0+half.probdv),(1-half.probdv))) parms.dv <- est.dv$estimate dv1 <- rlnorm(n.iter,parms.dv[1],parms.dv[2]) for(i in 1:n.iter){ dv[i] <- max(1,dv1[i]) } #- Harvest and Crippling loss not based on expert elicitation assumed Padding had best knowledge-# harvest <- c(15000,20069,26000) # Total harvest (number of birds) crip <- c(0.2,0.3,0.4) # Crippling loss est.harvest <- qmedist(harvest,"lnorm",probs=c(0.10,0.90)) parms.harvest <- est.harvest$estimate H.obs <- rlnorm(n.iter,parms.harvest[1],parms.harvest[2]) est.crip <- qmedist(crip,"beta",probs=c(0.10,0.90)) parms.crip <- est.crip$estimate crip <- rbeta(n.iter,parms.crip[1],parms.crip[2]) # Parameters from data # Clutch size is a weighted average by sample size cs1 <- 7.7*(20/(20+187))+8.7*(187/(20+187)) cs.sd <- 1.7*(20/(20+187))+1.37*(187/(20+187)) cs.dat <- c(cs1-(1.96*cs.sd), cs1,cs1+(1.96*cs.sd)) lnpriorcs.dat <- qmedist(cs.dat,"lnorm",probs=c(0.025,0.975)) lnparmscs.dat <- lnpriorcs.dat$estimate cs.mat[,2] <- rlnorm(n.iter,lnparmscs.dat[1],lnparmscs.dat[2]) ##### randomly sample from different experts to create the final distributions rnum2 <- round(rbinom(n.iter,1,0.5))+1 for(i in 1:n.iter){ cs[i] <- cs.mat[i,rnum2[i]] N[i] <- N.mat[i,rnum2[i]] } # Combine wing data with expert opinion (with equal weight) # calculate fecundity from wing and dv data w.rat <- 1.42; w.rat.sd <- w.rat*0.10 wings <- c(w.rat-(1.96*w.rat.sd), w.rat,w.rat+(1.96*w.rat.sd)) lnpriorwings <- qmedist(wings,"lnorm",probs=c(0.025,0.975)) lnparmswings <- lnpriorwings$estimate wings <- rlnorm(10000,lnparmswings[1],lnparmswings[2]) recruit.mat[,1] <- wings/dv # calculate fecundity from repro components b2 <- ((pfirstbr.2*cs*ns*hs*ds)/2) # fecundity of 2nd year breeders (from repro components) recruit.mat[,2] <- ((bp.ad*cs*ns*hs*ds)/2) # fecundity of adults (from repro components) # combine the two estimates rnum2 <- round(rbinom(n.iter,1,0.5))+1 for(i in 1:n.iter){ recruit[i] <- recruit.mat[i,rnum2[i]] } #----------------------------------------------- Run Simulations -------------------------------------------------# for(i in 1:n.iter){ # COMPUTE RMAX AND HMAX USING PROJECT MATRIX APPROACH A <- matrix(c(p1[i]*0,p2[i]*b2[i],p.ad[i]*recruit[i], p1[i],0,0, 0,p2[i],p.ad[i]),nrow=3,ncol=3,byrow=T) project.mat.r[i] <- lambda(A)-1 project.mat.h[i] <- (project.mat.r[i]*theta)/(1+(theta*(1+project.mat.r[i]))) # CALCULATE ALLOWABLE HARVEST LEVEL K[i] <- H.obs[i]/(1-crip[i]) H.projmat[i] <- N[i]*project.mat.h[i] # TRACK FREQUENCY OF EXPECT REALIZED HARVEST <= ALLOWABLE HARVEST projmatcomp[i] <- ifelse(H.projmat[i]