A Bayesian state-space model using age-at-harvest data for estimating the population of black bears (Ursus americanus) in Wisconsin Maximilian L. Allen, Andrew S. Norton, Glenn Stauffer, Nathan M. Roberts, Yanshi Luo, Qing Li, David MacFarland, and Timothy R. Van Deelen Supplementary Information 2a. The main R script, which calls in the scripts in Supplementary Material 2b & 2c. # ****************************************************************************************************************** # Date: April 3 2018 # Authors: Andrew Norton and Maximilian Allen # ****************************************************************************************************************** #Setup: # Save scripts (Run_JAGS_PM & JAGS_PM & FUNC_FIG) to your working directory folder. #===================================================================================================================== #================================ (1) Set Working Directory/Folders =============================== #===================================================================================================================== rm(list=ls()); library(abind); library(R2jags); library(taRifx); library(gdata); library(tidyr); library(dplyr) #set directory directory <- "C:/Users/Max Allen/BearPopulationModel/" #set working directory setwd("C:/Users/Max Allen/BearPopulationModel/") #all sourced R scripts need to be in this folder (need forward slash on end) resfld <- "results_jags" #'results folder' for results (need to create this folder within 'directory folder') resfld2 <- "harvrep_grp" #model structure 2 results folder name (need to create this folder within 'results folder') #====================================================================================================================== #================================= (2) Input Actual Data =========================================== #====================================================================================================================== age <- A <- 10 #number of age-classes (originally 13) Y <- 8 #years for model (pulls last Y years from simulated population) #assumed starting population >>> by sex/age class (needs to be logN for model) assumN <- array(0, dim = c(Y,A,2)) #21450 as starting population assumN.f.1 <- c(2229,2008,1115, 651,414,284,212,158,122,393) assumN.m.1 <- c(2529,2098,1115, 651,414,284,212,158,122,3) for(i in 1:10){ assumN[1,i,1] <- assumN.f.1[i] assumN[1,i,2] <- assumN.m.1[i] } logN <- t(log(array(assumN[1,,], dim=c(A,2)))) logN <- ifelse(logN<0,-5,logN) ###################################################### A1 <- read.csv(file = "A1.csv", header = F) A2 <- read.csv(file = "A2.csv", header = F) O <- read.csv(file = "O.csv", header = F) O.aged <- cbind(apply(A1,1,sum),apply(A2,1,sum)) #======================================================================================================================== #================================= (3) Specify IPM Parameters ======================================= #======================================================================================================================== ######################### Priors Means and Distributions Parameters ################################################## ##Priors priorHSf <- 0.85 #mean: HS female priorHSm <- 0.77 #mean: HS male priorNSmf <- 0.91 #mean: NS (both sexes) priorRepf <- 0.98 #mean: female percent of hunt seas mort related to legal harvest priorRepm <- 0.98 #mean: male percent of hunt seas mort related to legal harvest priorCubSA <- 0.84 #mean: cub survival from 0 to 0.5 priorCubSB <- 0.71 #mean: cub survival from 0.5 to 1.0 priorLSaa <- 20 #gamma a value for litter size of first age class priorLSab <- 10 #gamma b value for litter size of first age class priorLSba <- 20 #gamma a value for litter size of second age class priorLSbb <- 10 #gamma b value for litter size of second age class priorLSca <- 20 #gamma a value for litter size of third age class priorLScb <- 10 #gamma b value for litter size of third age class priorLSda <- 16.4 #gamma a value for litter size of fourth age class priorLSdb <- 6 #gamma b value for litter size of fourth age class priorPRaa <- 2.61 #gamma a value for pregnancy rate of first age class priorPRab <- 1000 #gamma b value for pregnancy rate of first age class priorPRba <- 34 #gamma a value for pregnancy rate of second age class priorPRbb <- 100 #gamma b value for pregnancy rate of second age class priorPRca <- 54 #gamma a value for pregnancy rate of third age class priorPRcb <- 48 #gamma b value for pregnancy rate of third age class priorPRda <- 47 #gamma a value for pregnancy rate of fourth age class priorPRdb <- 50 #gamma b value for pregnancy rate of fourth age class priorSPa <- 426 #gamma a value for sex proportion of male cubs priorSPb <- 500 #gamma b value for sex proportion of male cubs initpopbase <- 0 #prior min initial population for each age/sex cohort (can be 0's in older age-classes) initpopscale <- 3 #prior max scalar initial population for each age/sex cohort can be (e.g. 3 is 3 times cohort mean) #ranges for truncation repfrange <- c(0.6,1.0) #prior range for female percent of hunting season mortality related to legal harvest repmrange <- c(0.6,1.0) #prior range for male percent of hunting season mortality related to legal harvest hsfrange <- c(0.5,1.0) #prior range for female hunting season survival hsmrange <- c(0.4,.95) #prior range for female hunting season survival nsrange <- c(0.6,1.0) #prior range for survival outside the hunting season LSarange <- c(1,4) #prior range for Litter Size ageclass A LSbrange <- c(1,4) #prior range for Litter Size ageclass B LScrange <- c(1,4) #prior range for Litter Size ageclass C LSdrange <- c(1,6) #prior range for Litter Size ageclass D PRarange <- c(0.01,0.20) #prior range for Pregnancy Rate ageclass A PRbrange <- c(0.01,0.99) #prior range for Pregnancy Rate ageclass B PRcrange <- c(0.01,0.99) #prior range for Pregnancy Rate ageclass C PRdrange <- c(0.01,0.99) #prior range for Pregnancy Rate ageclass D #precision tau.logN <- 5 #precision: for intial pop (higher more informative) ***2 tau.cll.Report <- 2 #precision: % hunt more related to harvest (higher more informative) ***10 tau.LHR <- 10 #precision: offset for either juv male, juv fem vs ad fem HS or AM vs YM HS ***0.01 tau.mu.cll.HS <- 3 #precision: long-term mean of hunting season survival ***2 tau.mu.cll.NS <- 4 #precision: long-term mean of outside hunting season survival ***2 hs.gama <- c(20,20) #precision: higher relative to hs.gamb the more informative (sex) ***((5,12)) hs.gamb <- c(0.5,0.5) # ***(1,1) ns.gama <- 20 #precision: higher relative to ns.gamb the more informative ***3 ns.gamb <- 0.5 # ***(1) ##specify prior for Report pr.cll.Report <- log(-log(c(priorRepf,priorRepm))) ##specify prior for hunt season surv pr.cll.HS <- log(-log(c(priorHSf,priorHSm))) ##specify prior for outhunt surv (NS) pr.cll.NS <- log(-log(c(priorNSmf))) ##specify prior for cub Survival periods A & B mu.cll.CubSA <-log(-log(priorCubSA)) tau.cll.CubSA <-4 mu.cll.CubSB <-log(-log(priorCubSB)) tau.cll.CubSB <-4 ### Index for harvest rate offsets for group ## ref is 4 hr.idx= t(array(c(1,2,3,4,4,4,4,4,4,4,5,6,7,8,8,8,8,8,8,8), dim = c(A,2))) #======================================================================================================================== #================================ (3) Run Models =============================================== #======================================================================================================================== source(paste(directory, "\\JAGS_PM.R", sep="")) #write JAGS models ## Specify parameters to monitor in MCMC params <- c("Total","N", "HS", "NS","Report", "LSa", "LSb", "LSc", "LSd", "PRa", "PRb", "PRc", "PRd", "SP", "CubSA", "CubSB", "pN","pHS","pNS","pReport","pLSa", "pLSb", "pLSc", "pLSd", "pPRa", "pPRb", "pPRc", "pPRd","pSP", "pSPfem","pSPmal","pCubSA", "pCubSB") #specify parameters to monitor ## MCMC sampling niters <- 220000; nburn <- 20000; nthin <- 4; nchain <- 3 #specify iterations, burn-in, thinning, and chains for MCMC ## Specify data for jags # dataall is data that is common for all 5 model types dataall <- list(Y=Y, A=A, hr.idx=hr.idx, pr.cll.HS=pr.cll.HS, pr.cll.NS=pr.cll.NS, logN=logN, tau.logN=tau.logN, mu.cll.CubSA=mu.cll.CubSA, mu.cll.CubSB=mu.cll.CubSB, pr.cll.Report=pr.cll.Report, tau.cll.Report=tau.cll.Report, tau.LHR=tau.LHR, tau.mu.cll.HS=tau.mu.cll.HS, tau.mu.cll.NS=tau.mu.cll.NS, tau.cll.CubSA=tau.cll.CubSA, tau.cll.CubSB=tau.cll.CubSB, hs.gama=hs.gama, hs.gamb=hs.gamb, ns.gama=ns.gama, ns.gamb=ns.gamb, initpopbase=initpopbase, initpopscale=initpopscale, priorLSaa=priorLSaa, priorLSab=priorLSab, priorLSba=priorLSba, priorLSbb=priorLSbb, priorLSca=priorLSca, priorLScb=priorLScb, priorLSda=priorLSda, priorLSdb=priorLSdb, priorPRaa=priorPRaa, priorPRab=priorPRab, priorPRba=priorPRba, priorPRbb=priorPRbb, priorPRca=priorPRca, priorPRcb=priorPRcb, priorPRda=priorPRda, priorPRdb=priorPRdb, priorSPa=priorSPa, priorSPb=priorSPb, replow=log(-log(c(repfrange[1],repmrange[1]))), rephigh=log(-log(c(repfrange[2],repmrange[2]))), hslow=log(-log(c(hsfrange[1],hsmrange[1]))), hshigh=log(-log(c(hsfrange[2],hsmrange[2]))), nslow=log(-log(nsrange[1])), nshigh=log(-log(nsrange[2])), LSalow=LSarange[1], LSahigh=LSarange[2], LSblow=LSbrange[1], LSbhigh=LSbrange[2], LSclow=LScrange[1], LSchigh=LScrange[2], LSdlow=LSdrange[1], LSdhigh=LSdrange[2], PRalow=PRarange[1], PRahigh=PRarange[2], PRblow=PRbrange[1], PRbhigh=PRbrange[2], PRclow=PRcrange[1], PRchigh=PRcrange[2], PRdlow=PRdrange[1], PRdhigh=PRdrange[2] ) dataharvgrp <- c(dataall, list(O=O, A1=A1, A2=A2,O.aged=O.aged)) ##Run JAGS model gc() #free up RAM if needed system.time(jags2 <- jags.run(jagsharvgrp, dataharvgrp)) #args= (jagsmod,dat)) warnings() smrymod<-jags2$smrytemp; smrymod <- smrymod [ order(smrymod$Var, smrymod$c1, smrymod$c2, smrymod$c3, smrymod$c4),] View(smrymod) save(smrymod, file = "smrymod.RData") summary <-as.list(smrymod) write.csv(summary, file="summary") #======================================================================================================================== #================================ (4) Results/Figures ========================================== #======================================================================================================================== ## Create Gelman Diagnostic Values for the model jags2$geltot source(paste(directory, "jags_res_figs.R", sep="")) #source script for function that creates figures and summary table and writes to folder m1 <- 0; m2 <- max(popsim[yr1:(yr2+1)]*1.5) #m1 is the lower bound on y-axis, m2 is the upper bound on y-axis width <- 16; height <- 10; bins <- 5 #width and height of pop.fig(smry2, bins, "AAH - Rep Grp Sex w aged Subset", resfld2) #load packages library(ggplot2) library(dplyr) library(tidyr) library(stringr) dir("C:/Users/Max Allen/BearPopulationModel/") setwd("C:/Users/Max Allen/BearPopulationModel/") load("./smrymod.RData") dir <- "./Fig/" source("./func_fig.R") generateFigures(smrymod, dir) # generate 12 figures # auxilaryFig(smrymod, dir, auxiYear, auxiL95, auxiR95, auxiP) auxilaryFig(smrymod, dir, 2011, 20672, 24843, 22758) #========================================================================================================================