R/gen.R

In ggcostoya/limon: Evolutionary Constraints among Thermal Performance Traits

### * GENERATOR FUNCTIONS

 ## * GENERATE RANDOM ID

 #' Generate random individual identifier
 #'
 #' This function generates a random individual identifier.
 #'
 #' @return A unique eight character long string
 #'
 #' @examples
 #'
 #' replicate(10, gen_id())
 #'
 #' @export

 gen_id <- function() {paste0(sample(c(0:9, letters[1:6]), 8, replace = TRUE), collapse = "")}

 ### ** GENERATE THERMAL PERFORMANCE CURVE

 #' Generate TPC
 #'
 #' Generates a thermal-performance curve (TPC) from the results of a thermal-performance model (TPM)
 #'
 #' @param fit Fit object in the format of the output of the function fit_tpd
 #'
 #' @return A TPC dataset with temperature (t) and performance (p) data
 #'
 #' @examples
 #' tpd <- gen_base_tpd(topt = 30, tb = 5, skw = -2, ctmin = 15, ctmax = 35, pmax = 10, pmin = 0.1)
 #' fit <- fit_tpd(tpd)
 #' tpc <- gen_tpc(fit)
 #' plot(tpd, pch = 19, cex = 1.25)
 #' lines(tpc, lwd = 1.25, col = "lightgrey")
 #'
 #' @export

 gen_tpc <- function(fit){

     # sequence of hodler temperature values
     tseq <- seq(0,50, by = 0.01)

     # determine model name
     tpm <- fit %>% select(tpm)

     # extract parameters from model
     estimates <- fit %>% select(results) %>% unnest(cols = c(results)) %>% select(estimate) %>% as.data.frame() %>% as.vector()

     # generate predictive curve
     if(tpm == "flinn"){p <- flinn(tseq, estimates[1,1], estimates[2,1], estimates[3,1])}
     if(tpm == "gaussian"){p <- gaussian(tseq, estimates[1,1], estimates[2,1], estimates[3,1])}
     if(tpm == "spain"){p <- spain(tseq, estimates[1,1], estimates[2,1], estimates[3,1], estimates[4,1])}
     if(tpm == "weibull"){p <- weibull(tseq, estimates[1,1], estimates[2,1], estimates[3,1], estimates[4,1])}

     # get the final data frame
     tpc <- tibble(t = tseq, p = p)

     return(tpc)

 }

 ### * Generate Base TPD

 #' Generate base TPD
 #'
 #' Generates base thermal-performance data (TPD) from a vector of basic thermal-performance traits (TPTs).
 #'
 #' @param topt Thermal optimum.
 #' @param tb Thermal breath (set at 0.8 of Pmax).
 #' @param skw Curve skewness (set at 0.8 of Pmax).
 #' @param ctmin Critical thermal minimum.
 #' @param ctmax Critical thermal maximum.
 #' @param pmax Maximum pefromance.
 #' @param pmin Percentage of Pmax corresponding to the minimum performance.
 #'
 #' @return A TPD of length 5 with temperature (t) and performance (p) data
 #'
 #' @examples
 #' tpd <- gen_base_tpd(topt = 30, tb = 5, skw = -2, ctmin = 15, ctmax = 35, pmax = 10, pmin = 0.1)
 #' tpd
 #' plot(tpd, pch = 19, xlab = "Temperature", ylab = "Performance", cex = 1.5)
 #'
 #' @export

 gen_base_tpd <- function(topt, tb, skw, ctmin, ctmax, pmax, pmin){

     # define point values for temperature at tb
     tb_ctmin <- topt - tb/2 + skw/2
     tb_ctmax <- topt + tb/2 + skw/2

     # correct for unrealistic tb extreme t values
     tb_ctmin <- ifelse(tb_ctmin > topt, topt, tb_ctmin)
     tb_ctmax <- ifelse(tb_ctmax < topt, topt, tb_ctmax)

     # correct for unrealistic ctmin & ctmin t values
     ctmin <- ifelse(ctmin > tb_ctmin, tb_ctmin, ctmin)
     ctmax <- ifelse(ctmax < tb_ctmax, tb_ctmax, ctmax)

     # generate vector of temperature values
     t <- c(ctmin, tb_ctmin, topt, tb_ctmax, ctmax)

     # determine performance at 80% pmax, corresponds to p at tb
     p_tb <- pmax*pmin + (pmax-pmax*pmin)*0.8

     # generate vector of  performance values
     p <- c(pmax*pmin, p_tb, pmax, p_tb, pmax*pmin)

     return(tibble(t,p))

 }


 ### ** GENERATE TPD

 #' Generate TPD
 #'
 #' Generates a thermal-performance dataset (TPD) based on some thermal-performance traits (TPTs)
 #'
 #' @param tpts A TPTs tibble with trait and value as columns
 #' @param samples The number of samples to be generated.
 #' @param error The amount of error to be introduced in units of standard deviation.
 #'
 #' @return A thermal-performance dataset (TPD) with temperature (t) and performance as columns
 #'
 #' @examples
 #'
 #' tpd <- gen_base_tpd(topt = 30, tb = 3, skw = -1, ctmin = 20, ctmax = 35, pmax = 10, pmin = 0.1)
 #' fit <- fit_tpd(tpd)
 #' tpc <- gen_tpc(fit)
 #' tpts <- get_tpts(tpc, pmin = 0.1)
 #' tpd <- gen_tpd(tpts, samples = 10, error = 0.75)
 #' plot(tpd, pch = 19, ylim = c(0, max(tpc$p,tpd$p, na.rm = T)), xlab = "T", cex =1.25)
 #' lines(tpc, col = "royalblue", lwd = 1.25)
 #'
 #' @export

 gen_tpd <- function(tpts, samples, error){

     # function to extract tpts
     ex <- function(tpt_x){tpts %>% filter(tpt == tpt_x) %>% select(value) %>% as.numeric()}

     # generate base points from tpts
     bpts <- gen_base_tpd(topt = ex("topt"), tb = ex("tb"), skw = ex("skw"),ctmin = ex("ctmin"), ctmax = ex("ctmax"),
                          pmax = ex("pmax"), pmin = ex("pmin"))

     # fit the base points
     fit_bpts <- fit_tpd(bpts)

     # get the tpc and filter values that can be sampled
     tpc <- gen_tpc(fit_bpts) %>% filter(t > ex("ctmin") & t < ex("ctmax")) %>% filter(p > ex("pmax")*ex("pmin"))

     # sample data evenly depending on the number of samples wanted
     tpc <- tpc[1:samples*(nrow(tpc)/samples),]

     # add uncertaintites for the p measurement
     tpc$p <- tpc$p + rnorm(samples, 0, error)

     # if any performance value is below 0 keep it at zero
     tpc$p <- ifelse(tpc$p < 0, 0, tpc$p)

     return(tpc)

 }


 ### * GENERATE A POPULATIONS' TPD

 #' Generate a population's TPD
 #'
 #' Generates a population's thermal-performance dataset (TPD) based on some thermal performance traits (TPTs), the number of idnividuals (n), the amount of samples and a specified error.
 #'
 #' @param n The number of individuals
 #'
 #' @param tpts A data frame of thermal-performance traits (TPTs) in the format of the output of the get_tpts function
 #'
 #' @param samples The number of samples to be generated for each individual
 #'
 #' @param error The amount of error to be introduced in units of standard deviation.
 #'
 #' @return A tibble thermal-performance dataset (TPD) with id, p and t as columns
 #'
 #' @examples
 #'
 #' @export

 gen_pop_tpd <- function(n, tpts, samples, error){

     # Generate empty data frame
     pop_tpd <- tibble(id = factor(),t = logical(),p = logical())

     # Loop to generate data
     for(i in 1:n){

         # Generate a new individual
         ind_tpd <- as_tibble(data.frame(id = rep(gen_id(), samples), gen_tpd(tpts,samples,error)))

         # Attach individual to population
         pop_tpd <- rbind(pop_tpd, ind_tpd)
     }

     return(pop_tpd)

 }