R/gen.R

In ggcostoya/momentum:

### * GENERATOR FUNCTIONS

### ** GENERATE BASE POINTS

#' Generate base TPD points
#'
#' This function generates basic temperature and performance points equivalent to major thermal performance traits.
#'
#' @param Topt Thermal Optimum
#' @param Tb50 Temperature Breath at 50 percent Pmax
#' @param Tb80 Temperature Breath at 80 percent Pmax
#' @param Skw50 Skewness at 50 percent Pmax
#' @param Skw80 Temperature Skewness at 80 percent Pmax
#' @param Pmax Maximum Performance
#' @param Pmin Percentage of Pmax corresponding to Minimum Performance
#' @param CTmax Critical Thermal Maximum
#' @param CTmin Critical Thermal Minimum
#'
#' @return A thermal-peformance dataset (TPD)
#'
#' @examples
#'
#' x <- gen_base(25, 2, 1.25, 0, 0, 10, 0.5, 27, 23)
#' plot(x, type ="o")
#'
#' @export

 gen_base <- function(Topt, Tb50, Tb80, Skw50, Skw80, Pmax, Pmin, CTmax, CTmin){

   # temperature
   t <- c(CTmin,
          (Topt - Tb50/2 + Skw50/2),
          (Topt - Tb80/2 + Skw80/2),
          Topt,
          (Topt + Tb80/2 + Skw80/2),
          (Topt + Tb50/2 + Skw50/2),
          CTmax)

   # performance
   p <- c(Pmax*Pmin,
          mean(c(Pmax,Pmax*Pmin)),
          ((Pmax-Pmax*Pmin)*0.8 + Pmax*Pmin),
          Pmax,
          ((Pmax-Pmax*Pmin)*0.8 + Pmax*Pmin),
          mean(c(Pmax,Pmax*Pmin)),
          Pmax*Pmin)

   # bind datasets
   tpd <- data.frame(t,p)

   return(tpd)
}

 ## * 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
 #'
 #' This function generates a predicted thermal performance curve based on model fit data.
 #'
 #' @param fit A model summary dataset with a column for "model" used and columns for each of the parameters.
 #'
 #' @return A predicted TPC dataset with a temperature (t) and performance (p) columns
 #'
 #' @examples
 #'
 #' tpd <- gen_base(25, 4, 2, -0.25, 0.15, 10, 0.5, 27, 20)
 #' fit <- fit_tpd(tpd)
 #' curve <- gen_tpc(fit) # Generate the TPC from the model fit
 #' plot(tpd, pch = 19, xlab = "Temperature", ylab = "Performance")
 #' lines(curve,lwd = 2)
 #'
 #' @export
 #'
 gen_tpc <- function(fit){

    # Temperature holder sequence
    tseq <- seq(0,50, by = 0.1)

    # Generate the prdictive curve
    if(fit$model == "gaussian"){p <- pred_gaussian(tseq, fit$s, fit$a, fit$b)}
    if(fit$model == "emg"){p <- pred_emg(tseq, fit$s, fit$a, fit$b, fit$c)}
    if(fit$model == "weibull"){p <- pred_weibull(tseq, fit$s, fit$a, fit$b, fit$c)}

    # Return dataset
    tpc <- data.frame(t = tseq, p = p)

    return(tpc)
 }


 ### ** GENERATE AN INDIVIDUALS' TPD

 #' Generate an individual's thermal performance data (TPD)
 #'
 #' This function randomly generates an idnividual's TPD based on some TPTs, the amount of samples and the specified error.
 #'
 #' @param TPTs A data frame of TPTs
 #'
 #' @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)
 #'
 #' @examples
 #'
 #' traits <- data.frame(Topt = 25, Tb50 = 4, Tb80 = 2, Skw50 = -0.25, Skw80 = 0.15, Pmax = 10, Pmin = 0.5, CTmax = 27, CTmin = 20)
 #' tpd <- gen_tpd(traits, 10, 1)
 #' tpd
 #' plot(tpd)
 #'
 #' @export

 gen_tpd <- function(TPTs, Samples, Error){

     # Generate base data
     base_points <- gen_base(TPTs$Topt, TPTs$Tb50, TPTs$Tb80, TPTs$Skw50, TPTs$Skw80, TPTs$Pmax, TPTs$Pmin, TPTs$CTmax, TPTs$CTmin)

     # Get the fit for those base points
     base_fit <- fit_tpd(base_points)

     # Draw the curve
     base_curve <- gen_tpc(base_fit)

     # Filter the points of the curve that can be chosen
     base_curve <- base_curve %>% filter(t > TPTs$CTmin & t < TPTs$CTmax) %>% filter(p > TPTs$Pmax*TPTs$Pmin)

     # Sample data evenly depending on the numbr of 'Samples' wanted
     base_curve <- base_curve[1:Samples*(nrow(base_curve)/Samples),]

     # Add uncertainties for the p measurement
     base_curve$p <- base_curve$p + rnorm(Samples, 0, Error)

     return(base_curve)

 }