insect_phenology_model: insect_phenology

comparison insect_phenology_model.R @ 5:1878a03f9c9f draft

Uploaded

author	greg
date	Wed, 22 Nov 2017 13:22:49 -0500
parents	e7b1fc0133bb
children	fe3f86012394

comparison

equal deleted inserted replaced

-:e7b1fc0133bb
+:1878a03f9c9f
 make_option(c("-p", "--oviposition"), action="store", dest="oviposition", type="integer", help="Adjustment for oviposition rate"),
 make_option(c("-q", "--photoperiod"), action="store", dest="photoperiod", type="double", help="Critical photoperiod for diapause induction/termination"),
 make_option(c("-s", "--replications"), action="store", dest="replications", type="integer", help="Number of replications"),
 make_option(c("-t", "--se_plot"), action="store", dest="se_plot", help="Plot SE"),
 make_option(c("-v", "--input"), action="store", dest="input", help="Temperature data for selected location"),
-make_option(c("-y", "--young_nymph_accum"), action="store", dest="young_nymph_accum", type="integer", help="Adjustment of DD accumulation (egg->young nymph)")
+make_option(c("-y", "--young_nymph_accum"), action="store", dest="young_nymph_accum", type="integer", help="Adjustment of DD accumulation (egg->young nymph)"),
+make_option(c("-x", "--insect"), action="store", dest="insect", help="Insect name")
 )
 parser <- OptionParser(usage="%prog [options] file", option_list=option_list)
 args <- parse_args(parser, positional_arguments=TRUE)
 opt <- args$options
-get_daylight_length = function(latitude, temperature_data, num_days)
+parse_input_data = function(input_file, num_rows) {
-{
+# Read in the input temperature datafile into a data frame.
+temperature_data_frame <- read.csv(file=input_file, header=T, strip.white=TRUE, sep=",")
+num_columns <- dim(temperature_data_frame)[2]
+if (num_columns == 6) {
+# The input data has the following 6 columns:
+# LATITUDE, LONGITUDE, DATE, DOY, TMIN, TMAX
+# Set the column names for access when adding daylight length..
+colnames(temperature_data_frame) <- c("LATITUDE","LONGITUDE", "DATE", "DOY", "TMIN", "TMAX")
+# Add a column containing the daylight length for each day.
+temperature_data_frame <- add_daylight_length(temperature_data_frame, num_columns, num_rows)
+# Reset the column names with the additional column for later access.
+colnames(temperature_data_frame) <- c("LATITUDE","LONGITUDE", "DATE", "DOY", "TMIN", "TMAX", "DAYLEN")
+}
+return(temperature_data_frame)
+}
+add_daylight_length = function(temperature_data_frame, num_columns, num_rows) {
 # Return a vector of daylight length (photoperido profile) for
 # the number of days specified in the input temperature data
 # (from Forsythe 1995).
 p = 0.8333
+latitude <- temperature_data_frame$LATITUDE[1]
 daylight_length_vector <- NULL
-for (i in 1:num_days) {
+for (i in 1:num_rows) {
 # Get the day of the year from the current row
 # of the temperature data for computation.
-doy <- temperature_data[i, 4]
+doy <- temperature_data_frame$DOY[i]
 theta <- 0.2163108 + 2 * atan(0.9671396 * tan(0.00860 * (doy - 186)))
 phi <- asin(0.39795 * cos(theta))
 # Compute the length of daylight for the day of the year.
 daylight_length_vector[i] <- 24 - (24 / pi * acos((sin(p * pi / 180) + sin(latitude * pi / 180) * sin(phi)) / (cos(latitude * pi / 180) * cos(phi))))
 }
-daylight_length_vector
+# Append daylight_length_vector as a new column to temperature_data_frame.
-}
+temperature_data_frame[, num_columns+1] <- daylight_length_vector
+return(temperature_data_frame)
-get_temperature_at_hour = function(latitude, temperature_data, daylight_length_vector, row, num_days)
+}
-{
+get_temperature_at_hour = function(latitude, temperature_data_frame, row, num_days) {
 # Base development threshold for Brown Marmolated Stink Bug
 # insect phenology model.
 # TODO: Pass insect on the command line to accomodate more
 # the just the Brown Marmolated Stink Bub.
 threshold <- 14.17
-# Input temperature currently has the following columns.
-# # LATITUDE, LONGITUDE, DATE, DOY, TMIN, TMAX
 # Minimum temperature for current row.
-dnp <- temperature_data[row, 5]
+dnp <- temperature_data_frame$TMIN[row]
 # Maximum temperature for current row.
-dxp <- temperature_data[row, 6]
+dxp <- temperature_data_frame$TMAX[row]
 # Mean temperature for current row.
 dmean <- 0.5 * (dnp + dxp)
 # Initialize degree day accumulation
 dd <- 0
 if (dxp < threshold) {
 # Initialize hourly temperature.
 T <- NULL
 # Initialize degree hour vector.
 dh <- NULL
 # Daylight length for current row.
-y <- daylight_length_vector[row]
+y <- temperature_data_frame$DAYLEN[row]
 # Darkness length.
 z <- 24 - y
 # Lag coefficient.
 a <- 1.86
 # Darkness coefficient.
 }
 }
 }
 dd <- sum(dh) / 24
 }
-return=c(dmean, dd)
+return(c(dmean, dd))
-return
+}
-}
+dev.egg = function(temperature) {
-dev.egg = function(temperature)
-{
 dev.rate= -0.9843 * temperature + 33.438
-return = dev.rate
+return(dev.rate)
-return
+}
-}
+dev.young = function(temperature) {
-dev.young = function(temperature)
-{
 n12 <- -0.3728 * temperature + 14.68
 n23 <- -0.6119 * temperature + 25.249
 dev.rate = mean(n12 + n23)
-return = dev.rate
+return(dev.rate)
-return
+}
-}
+dev.old = function(temperature) {
-dev.old = function(temperature)
-{
 n34 <- -0.6119 * temperature + 17.602
 n45 <- -0.4408 * temperature + 19.036
 dev.rate = mean(n34 + n45)
-return = dev.rate
+return(dev.rate)
-return
+}
-}
+dev.emerg = function(temperature) {
-dev.emerg = function(temperature)
-{
 emerg.rate <- -0.5332 * temperature + 24.147
-return = emerg.rate
+return(emerg.rate)
-return
+}
-}
+mortality.egg = function(temperature) {
-mortality.egg = function(temperature)
-{
 if (temperature < 12.7) {
 mort.prob = 0.8
 }
 else {
 mort.prob = 0.8 - temperature / 40.0
 if (mort.prob < 0) {
 mort.prob = 0.01
 }
 }
-return = mort.prob
+return(mort.prob)
-return
+}
-}
+mortality.nymph = function(temperature) {
-mortality.nymph = function(temperature)
-{
 if (temperature < 12.7) {
 mort.prob = 0.03
 }
 else {
 mort.prob = temperature * 0.0008 + 0.03
 }
-return = mort.prob
+return(mort.prob)
-return
+}
-}
+mortality.adult = function(temperature) {
-mortality.adult = function(temperature)
-{
 if (temperature < 12.7) {
 mort.prob = 0.002
 }
 else {
 mort.prob = temperature * 0.0005 + 0.02
 }
-return = mort.prob
+return(mort.prob)
-return
+}
-}
+temperature_data_frame <- parse_input_data(opt$input, opt$num_days)
-# Read in the input temperature datafile into a Data Frame object.
+# All latitude values are the same,
-# The input data currently must have 6 columns:
+# so get the value from the first row.
-# LATITUDE, LONGITUDE, DATE, DOY, TMIN, TMAX
+latitude <- temperature_data_frame$LATITUDE[1]
-temperature_data <- read.csv(file=opt$input, header=T, strip.white=TRUE, sep=",")
-start_date <- temperature_data[1, 3]
-end_date <- temperature_data[opt$num_days, 3]
-latitude <- temperature_data[1, 1]
-daylight_length_vector <- get_daylight_length(latitude, temperature_data, opt$num_days)
 cat("Number of days: ", opt$num_days, "\n")
 # Initialize matrix for results from all replications.
 S0.rep <- S1.rep <- S2.rep <- S3.rep <- S4.rep <- S5.rep <- matrix(rep(0, opt$num_days * opt$replications), ncol = opt$replications)
 newborn.rep <- death.rep <- adult.rep <- pop.rep <- g0.rep <- g1.rep <- g2.rep <- g0a.rep <- g1a.rep <- g2a.rep <- matrix(rep(0, opt$num_days * opt$replications), ncol=opt$replications)
-# loop through replications
+# Loop through replications.
 for (N.rep in 1:opt$replications) {
 # During each replication start with 1000 individuals.
 # TODO: user definable as well?
 n <- 1000
 # Generation, Stage, DD, T, Diapause.
 gen2.pop <- rep(0, opt$num_days)
 S0 <- S1 <- S2 <- S3 <- S4 <- S5 <- rep(0, opt$num_days)
 g0.adult <- g1.adult <- g2.adult <- rep(0, opt$num_days)
 N.newborn <- N.death <- N.adult <- rep(0, opt$num_days)
 dd.day <- rep(0, opt$num_days)
 # All the days included in the input temperature dataset.
 for (row in 1:opt$num_days) {
 # Get the integer day of the year for the current row.
-doy <- temperature_data[row, 4]
+doy <- temperature_data_frame$DOY[row]
 # Photoperiod in the day.
-photoperiod <- daylight_length_vector[row]
+photoperiod <- temperature_data_frame$DAYLEN[row]
-temp.profile <- get_temperature_at_hour(latitude, temperature_data, daylight_length_vector, row, opt$num_days)
+temp.profile <- get_temperature_at_hour(latitude, temperature_data_frame, row, opt$num_days)
 mean.temp <- temp.profile[1]
 dd.temp <- temp.profile[2]
 dd.day[row] <- dd.temp
 # Trash bin for death.
 death.vec <- NULL
 # Newborn.
 birth.vec <- NULL
 # All individuals.
 for (i in 1:n) {
 # Find individual record.
 vec.ind <- vec.mat[i,]
 # First of all, still alive?
 # Add 1 day in current stage.
 vec.ind[4] <- vec.ind[4] + 1
 vec.mat[i,] <- vec.ind
 }
 }
 # Event 2 oviposition -- where population dynamics comes from.
 if (vec.ind[2] == 4 && vec.ind[1] == 0 && mean.temp > 10) {
 # Vittelogenic stage, overwintering generation.
 if (vec.ind[4] == 0) {
 # Just turned in vittelogenic stage.
 new.vec <- t(matrix(new.vec, nrow=5))
 # Group with total eggs laid in that day.
 birth.vec <- rbind(birth.vec, new.vec)
 }
 }
+# Event 2 oviposition -- for generation 1.
-# Event 2 oviposition -- for gen 1.
 if (vec.ind[2] == 4 && vec.ind[1] == 1 && mean.temp > 12.5 && doy < 222) {
 # Vittelogenic stage, 1st generation
 if (vec.ind[4] == 0) {
 # Just turned in vittelogenic stage.
 n.birth=round(runif(1, 2 + opt$min_clutch_size, 8 + opt$max_clutch_size))
 new.vec <- t(matrix(new.vec, nrow=5))
 # Group with total eggs laid in that day.
 birth.vec <- rbind(birth.vec, new.vec)
 }
 }
 # Event 3 development (with diapause determination).
 # Event 3.1 egg development to young nymph (vec.ind[2]=0 -> egg).
 if (vec.ind[2] == 0) {
 # Egg stage.
 # Add to dd.
 # Add 1 day in current stage.
 vec.ind[4] <- vec.ind[4] + 1
 }
 vec.mat[i,] <- vec.ind
 }
 # Event 3.2 young nymph to old nymph (vec.ind[2]=1 -> young nymph: determines diapause).
 if (vec.ind[2] == 1) {
 # young nymph stage.
 # add to dd.
 vec.ind[3] <- vec.ind[3] + dd.temp
 # Add 1 day in current stage.
 vec.ind[4] <- vec.ind[4] + 1
 }
 vec.mat[i,] <- vec.ind
 }
 # Event 3.3 old nymph to adult: previttelogenic or diapausing?
 if (vec.ind[2] == 2) {
 # Old nymph stage.
 # add to dd.
 vec.ind[3] <- vec.ind[3] + dd.temp
 # Add 1 day in current stage.
 vec.ind[4] <- vec.ind[4] + 1
 }
 vec.mat[i,] <- vec.ind
 }
 # Event 4 growing of diapausing adult (unimportant, but still necessary).
 if (vec.ind[2] == 5) {
 vec.ind[3] <- vec.ind[3] + dd.temp
 vec.ind[4] <- vec.ind[4] + 1
 vec.mat[i,] <- vec.ind
 }
 } # Else if it is still alive.
 } # End of the individual bug loop.
 # Find how many died.
 n.death <- length(death.vec)
 if (n.death > 0) {
 vec.mat <- vec.mat[-death.vec, ]
 }
 }
 # Data analysis and visualization can currently
 # plot only within a single calendar year.
 # TODO: enhance this to accomodate multiple calendar years.
+start_date <- temperature_data_frame$DATE[1]
+end_date <- temperature_data_frame$DATE[opt$num_days]
 n.yr <- 1
 day.all <- c(1:opt$num_days * n.yr)
 # mean value for adults
 sa <- apply((S3.rep + S4.rep + S5.rep), 1, mean)
 pdf(file=opt$output, width=20, height=30, bg="white")
 par(mar = c(5, 6, 4, 4), mfrow=c(3, 1))
 # Subfigure 1: population size by life stage
-title <- paste("BSMB total population by life stage :", opt$location, ": Lat:", latitude, ":", start_date, "to", end_date, sep=" ")
+title <- paste(opt$insect, ": Total pop. by life stage :", opt$location, ": Lat:", latitude, ":", start_date, "-", end_date, sep=" ")
 plot(day.all, sa, main=title, type="l", ylim=c(0, max(se + se.se, sn + sn.se, sa + sa.se)), axes=F, lwd=2, xlab="", ylab="", cex=3, cex.lab=3, cex.axis=3, cex.main=3)
 # Young and old nymphs.
 lines(day.all, sn, lwd=2, lty=1, col=2)
 # Eggs
 lines(day.all, se, lwd=2, lty=1, col=4)
 lines (day.all, se + se.se, col=4, lty=2)
 lines (day.all, se - se.se, col=4, lty=2)
 }
 # Subfigure 2: population size by generation
-title <- paste("BSMB total population by generation :", opt$location, ": Lat:", latitude, ":", start_date, "to", end_date, sep=" ")
+title <- paste(opt$insect, ": Total pop. by generation :", opt$location, ": Lat:", latitude, ":", start_date, "-", end_date, sep=" ")
 plot(day.all, g0, main=title, type="l", ylim=c(0, max(g2)), axes=F, lwd=2, xlab="", ylab="", cex=3, cex.lab=3, cex.axis=3, cex.main=3)
 lines(day.all, g1, lwd = 2, lty = 1, col=2)
 lines(day.all, g2, lwd = 2, lty = 1, col=4)
 axis(1, at=c(1:12) * 30 - 15, cex.axis=3, labels = c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"))
 axis(2, cex.axis=3)
 lines (day.all, g2+g2.se, col=4, lty=2)
 lines (day.all, g2-g2.se, col=4, lty=2)
 }
 # Subfigure 3: adult population size by generation
-title <- paste("BSMB adult population by generation :", opt$location, ": Lat:", latitude, ":", start_date, "to", end_date, sep=" ")
+title <- paste(opt$insect, ": Adult pop. by generation :", opt$location, ": Lat:", latitude, ":", start_date, "-", end_date, sep=" ")
 plot(day.all, g0a, ylim=c(0, max(g2a) + 100), main=title, type="l", axes=F, lwd=2, xlab="", ylab="", cex=3, cex.lab=3, cex.axis=3, cex.main=3)
 lines(day.all, g1a, lwd = 2, lty = 1, col=2)
 lines(day.all, g2a, lwd = 2, lty = 1, col=4)
 axis(1, at=c(1:12) * 30 - 15, cex.axis=3, labels = c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"))
 axis(2, cex.axis=3)

Mercurial > repos > greg > insect_phenology_model

comparison insect_phenology_model.R @ 5:1878a03f9c9f draft