R/pred.R

In ggcostoya/momentum:

### * PREDICT THERMAL PERFORMANCE TRAITS

#' Predict thermal performance traits (TPTs)
#'
#' This function makes a prediction on TPT values based on TPD
#'
#' @param curve A thermal-performance dataset (TPC) with "t" for temperature and "p" for performance as columns
#' @param Pmin The percentage of Pmax corresponding to Pmin
#'
#' @return A vector of predicted TPTs
#'
#' @examples
#'
#'
#' original_tpts <- data.frame(Topt = 25, Tb50 = 4, Tb80 = 2, Skw50 = -0.25, Skw80 = 0.15, Pmax = 10, Pmin = 0.1, CTmax = 27, CTmin = 20)
#' tpd <- gen_tpd(original_traits, 10, 0)
#' fit <- fit_tpd(tpd)
#' tpc <- gen_tpc(fit)
#' predicted_tpts <- pred_tpts(tpc,0.1)
#' cbind(tpts = c("original","predicted"),rbind(original_tpts,predicted_tpts))
#'
#' @export

pred_tpts <- function(tpc,Pmin){

  # Extracting TPTs from the TPC
  Pmax <- max(tpc$p, na.rm = T)
  Topt <- tpc %>% filter(p == Pmax) %>% select(t) %>% as.numeric()
  pmin <- Pmax*Pmin
  CTmin <- tpc %>% filter(t < Topt) %>% filter(p == Closest(p,pmin, na.rm = TRUE)) %>% select(t) %>% as.numeric()
  CTmax <- tpc %>% filter(t > Topt) %>% filter(p == Closest(p,pmin, na.rm = TRUE)) %>% select(t) %>% as.numeric()
  p50 <- pmin + (Pmax-pmin)*0.5
  ctmin50 <- tpc %>% filter(t < Topt) %>% filter(p == Closest(p,p50, na.rm = TRUE)) %>% select(t) %>% as.numeric()
  ctmax50 <- tpc %>% filter(t > Topt) %>% filter(p == Closest(p,p50, na.rm = TRUE)) %>% select(t) %>% as.numeric()
  Tb50 <- ctmax50 - ctmin50
  Skw50 <- ctmax50 - Topt - Topt + ctmin50
  p80 <- pmin + (Pmax-pmin)*0.8
  ctmin80 <- tpc %>% filter(t < Topt) %>% filter(p == Closest(p,p80, na.rm = TRUE)) %>% select(t) %>% as.numeric()
  ctmax80 <- tpc %>% filter(t > Topt) %>% filter(p == Closest(p,p80, na.rm = TRUE)) %>% select(t) %>% as.numeric()
  Tb80 <- ctmax80 - ctmin80
  Skw80 <- ctmax80 - Topt - Topt + ctmin80

  # Fitting them in a data.frame
  tpts <- data.frame(Topt, Tb50, Tb80, Skw50, Skw80, Pmax, Pmin, CTmax, CTmin)

  return(tpts)

}


### * TPC Predictor Funcions

### ** GAUSSIAN

#' Gaussian predictor function (extracted from Angilletta 2006).
#'
#' @param x A vector of values.
#' @param s Scaling parameter.
#' @param a Function prameter (roughly representing mean).
#' @param b Function parameter (roughly representing sd).
#'
#' @return A vector of predicted values.
#'
#' @examples
#'
#' tseq <- seq(0,100,by=0.1) # Mock temperature se
#' tpd <- gen_base(25, 4, 2, -0.25, 0.15, 10, 0.5, 27, 20) # Generate data
#'
#' # Predictor functions
#' gauss <- pred_gaussian(tseq,9.313,24.215,3.421) # Gaussian predictor function
#' emg <- pred_emg(tseq,18.2635,24.113,3.56350,0.09797)
#' weibull <- pred_weibull(tseq, 9.665, 24.66, 18330.366, 6362.136)
#'
#' #Plotting
#' plot(tpd,pch=19)
#' lines(tseq,emg, type = "l", lwd = 2, col = "grey")
#' lines(tseq, weibull, type = "l", lwd = 1, col = "grey")
#' lines(tseq,gauss,type="l", lwd = 2, col = "black")
#' @export

pred_gaussian <- function(x,s,a,b){

  y <- s*exp(-0.5*((x-a)/b)^2)

  return(y)

}

### * EXPONENTIALLY MODIFIED GAUSSIAN

#' Exponentially Modified Gaussian (EMG) predictor function (extracted from Angiletta 2006).
#'
#' @param x A vector of values.
#' @param s Scaling parameter.
#' @param a Function parameter (roughly representing mean).
#' @param b Function parameter (roughly representing sd).
#' @param c Function parameter.
#'
#' @return A vector of predicted values.
#'
#' @examples
#'
#' tseq <- seq(0,100,by=0.1) # Mock temperature se
#' tpd <- gen_base(25, 4, 2, -0.25, 0.15, 10, 0.5, 27, 20) # Generate data
#'
#' # Predictor functions
#' gauss <- pred_gaussian(tseq,9.313,24.215,3.421)
#' emg <- pred_emg(tseq,18.2635,24.113,3.56350,0.09797) # EMG predictor function
#' weibull <- pred_weibull(tseq, 9.665, 24.66, 18330.366, 6362.136)
#'
#' #Plotting
#' plot(tpd,pch=19)
#' lines(tseq,gauss, type = "l", lwd = 2, col = "grey")
#' lines(tseq, weibull, type = "l", lwd = 1, col = "grey")
#' lines(tseq,emg,type="l", lwd = 2, col = "black")
#' @export


pred_emg <- function(x,s,a,b,c){

  y <- s*(b/(2*c))*sqrt(pi/2)*exp(0.5*(b/c)^2 - (x-a)/c)*erfc((1/sqrt(2))*(b/c - (x-a)/b))

  return(y)
}


### * WEIBULL (MODIFIED)

#' Weibull predictor function (extracted from rTPC package)
#'
#' @param x A vector of values.
#' @param s Scaling parameter.
#' @param a Function parameter. Equivalent to Topt
#' @param b Function parameter. Defines breath
#' @param c Function parameter. Defines curve shape
#'
#' @return A vector of predicted values
#'
#' @examples
#'
#' tseq <- seq(0,100,by=0.1) # Mock temperature se
#' tpd <- gen_base(25, 4, 2, -0.25, 0.15, 10, 0.5, 27, 20) # Generate data
#'
#' # Predictor functions
#' gauss <- pred_gaussian(tseq,9.313,24.215,3.421)
#' emg <- pred_emg(tseq,18.2635,24.113,3.56350,0.09797)
#' weibull <- pred_weibull(tseq, 9.665, 24.66, 18330.366, 6362.136) # Weibull predictor function
#'
#' #Plotting
#' plot(tpd,pch=19)
#' lines(tseq,gauss, type = "l", lwd = 2, col = "grey")
#' lines(tseq, emg, type = "l", lwd = 1, col = "grey")
#' lines(tseq,weibull,type="l", lwd = 2, col = "black")
#' @export


pred_weibull <- function(x,s,a,b,c){

  y <- ((s*(((c-1)/c)^((1-c)/c))*((((x-a)/b)+(((c-1)/c)^(1/c)))^(c-1))*(exp(-((((x-a)/b)+(((c-1)/c)^(1/c)))^c)+((c-1)/c)))))

  return(y)

}