R/PopParam.R

In darrennorris/cmartr: Functions for processing and analysing river turtle management

#' @title Create data.frame with demographic parameters
#' 
#' @description Creates data.frame with parameters for use in subsequent
#' population projection function ("PopProj.R") 
#'
#' @param species Name of species. Default is "Podocnemis unifilis"
#' @param make_rds Logical (TRUE/FALSE). Should .RDS format be written.
#' Default is FALSE
#'
#' @details This function holds the demographic parameters used 
#' in population projections. When called by a user, it will create 
#' a data.frame with these demogrpahic parameters.
#' @return Creates data.frame with parameters used in "PopProj.R".
#' @export
#'
#' @examples
#' \dontrun{
#' dfpop <- PopParam(species = "Podocnemis unifilis", make_rds = FALSE)
#' }
#' 
PopParam <- function(species = "Podocnemis unifilis", make_rds = FALSE){
  
  sp <- species
  # parameters
  # female fecundity
  cfreq = 1.10 #clutch frequency
  csize = 21.00 # clutch size James
  csize.araguari = 14.00 # clutch size Araguari
  sratio = 0.5 # sex ratio
  ffec <- (cfreq * csize * sratio) # female fecundity
  
  #"Graduation" (First year survival and transition)
  esur <- 0.10
  emonths <- 2
  hsur <- 0.22
  hmonths <- (12 - emonths)
  ehsur <- ((esur*emonths)+(hsur*hmonths))/(emonths+hmonths) #0.2
  
  # define first year Graduation for projections
  ehsur1 <- c(0,0.1,ehsur, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9)
  
  # juvenile
  jearlysur <- 0.5
  jearlyears <- 2
  jlatesur <- 0.4
  jlateyears <- 2
  
  # early juvenile survive and stay (P) / survive and transition (G)
  jePn <- 1 - (jearlysur^(jearlyears - 1))
  jePd <- (1 - (jearlysur^jearlyears))
  jeP <- (jePn / jePd)*jearlysur
  jeG <- ((jearlysur^jearlyears)*(1-jearlysur)) / (1 - (jearlysur^jearlyears))
  
  # late juvenile survive and stay (P) / survive and transition (G)
  jlPn <- 1 - (jlatesur^(jlateyears - 1))
  jlPd <- (1 - (jlatesur^jlateyears))
  jlP <- (jlPn / jlPd)*jlatesur
  jlG <- ((jlatesur^jlateyears)*(1-jlatesur)) / (1 - (jlatesur^jlateyears))
  
  #adult survival
  asur <- 0.93
  
  
  # make data frame with row holding parameters for each population 
  dfpop <- 
    rbind(
      data.frame(
        species = sp,
        type = "headstart",   #set PPM element values,
        increase = as.character(ehsur1),
        a1 = 0,   #leave = 0
        a2 = 0,  #leave = 0,
        a3 = 0,
        a4 = ffec,  #fecundity per female,
        b1 = ehsur1, # default = 0.45
        b2 = 0.333333,  #juv_early survival adjusted for years as juv_early,
        b3 = 0,  # leave = zero,
        b4 = 0,
        c1 = 0,
        c2 = 0.166667,
        c3 = 0.285714, #juv_early ~graduation~ probability
        c4 = 0,
        d1 = 0,  #leave = zero,
        d2 = 0, #leave = zero
        d3 = 0.114286, #juv_late "graduation" probability,
        d4 = asur  #default = 0.93
      ),
      data.frame(
        species = sp,
        type = "headstart, female-hunt 2.5%",   #set PPM element values
        increase = as.character(ehsur1),
        a1 = 0,   #leave = 0
        a2 = 0,  #leave = 0,
        a3 = 0,
        a4 = ffec,  #fecundity per female,
        b1 = ehsur1, # default = 0.45
        b2 = 0.333333,  #juv_early survival adjusted for years as juv_early,
        b3 = 0,  # leave = zero,
        b4 = 0,
        c1 = 0,
        c2 = 0.166667,
        c3 = 0.285714, #juv_early ~graduation~ probability
        c4 = 0,
        d1 = 0,  #leave = zero,
        d2 = 0, #leave = zero
        d3 = 0.114286, #juv_late "graduation" probability,
        d4 = (asur * 0.975) #default = 0.93
      ),
      data.frame(
        species = sp,
        type = "headstart, female-hunt 10%",   #set PPM element values
        increase = as.character(ehsur1),
        a1 = 0,   #leave = 0
        a2 = 0,  #leave = 0,
        a3 = 0,
        a4 = ffec,  #fecundity per female,
        b1 = ehsur1, # default = 0.45
        b2 = 0.333333,  #juv_early survival adjusted for years as juv_early,
        b3 = 0,  # leave = zero,
        b4 = 0,
        c1 = 0,
        c2 = 0.166667,
        c3 = 0.285714, #juv_early ~graduation~ probability
        c4 = 0,
        d1 = 0,  #leave = zero,
        d2 = 0, #leave = zero
        d3 = 0.114286, #juv_late "graduation" probability,
        d4 = (asur * 0.90) #default = 0.93
      ),
      data.frame(
        species = sp,
        type = "headstart, female-hunt 25%",   #set PPM element values
        increase = as.character(ehsur1),
        a1 = 0,   #leave = 0
        a2 = 0,  #leave = 0,
        a3 = 0,
        a4 = ffec,  #fecundity per female,
        b1 = ehsur1, # default = 0.45
        b2 = 0.333333,  #juv_early survival adjusted for years as juv_early,
        b3 = 0,  # leave = zero,
        b4 = 0,
        c1 = 0,
        c2 = 0.166667,
        c3 = 0.285714, #juv_early ~graduation~ probability
        c4 = 0,
        d1 = 0,  #leave = zero,
        d2 = 0, #leave = zero
        d3 = 0.114286, #juv_late "graduation" probability,
        d4 = (asur * 0.75)  #default = 0.93
      ),
      data.frame(
        species = sp,
        type = "headstart, female-hunt 50%",   #set PPM element values
        increase = as.character(ehsur1),
        a1 = 0,   #leave = 0
        a2 = 0,  #leave = 0,
        a3 = 0,
        a4 = ffec,  #fecundity per female,
        b1 = ehsur1, # default = 0.45
        b2 = 0.333333,  #juv_early survival adjusted for years as juv_early,
        b3 = 0,  # leave = zero,
        b4 = 0,
        c1 = 0,
        c2 = 0.166667,
        c3 = 0.285714, #juv_early ~graduation~ probability
        c4 = 0,
        d1 = 0,  #leave = zero,
        d2 = 0, #leave = zero
        d3 = 0.114286, #juv_late "graduation" probability,
        d4 = (asur * 0.5)  #default = 0.93
      )
    )
  
  dfpop$akey <- paste(dfpop$species, dfpop$type, dfpop$increase, sep = "_")
  levels(dfpop$type) <- c("0", "2.5", "10", "25", "50") 
  dfpop$type <- as.numeric(as.character(dfpop$type))
  dfpop$increase <- as.numeric(as.character(dfpop$increase))
  
  if(make_rds!=FALSE){
  saveRDS(dfpop, "inst/other/dfpop.RDS") 
  }
  return(dfpop)
  
}