R/get.R

In ggcostoya/limon: Evolutionary Constraints among Thermal Performance Traits

### * Get TPTs

#' Get TPTs
#'
#' Gets thermal-performance trait (TPT) values from a thermal-performance curve (TPC)
#'
#' @param tpc 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 tibble with trait and value as columns.
#'
#' @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)
#' tpts <- get_tpts(tpc)
#' tpts
#'
#' @export

get_tpts <- function(tpc, pmin){

  # extract TPTs from the TPC
  pmax <- max(tpc$p, na.rm = T)
  topt <- tpc %>% filter(p == pmax) %>% select(t) %>% as.numeric()
  min_p <- pmax * pmin
  ctmin <- tpc %>% filter(t <= topt) %>% filter(p == Closest(p, min_p, na.rm = T)) %>% select(t) %>% as.numeric()
  ctmax <- tpc %>% filter(t >= topt) %>% filter(p == Closest(p, min_p, na.rm = T)) %>% select(t) %>% as.numeric()
  p_tb <- min_p + (pmax-min_p)*0.8 # performance at 80% pmax
  tb_ctmin <- tpc %>% filter(t <= topt) %>% filter(p == Closest(p, p_tb, na.rm = T)) %>% select(t) %>% as.numeric()
  tb_ctmax <- tpc %>% filter(t >= topt) %>% filter(p == Closest(p, p_tb, na.rm = T)) %>% select(t) %>% as.numeric()
  tb <- tb_ctmax - tb_ctmin
  skw <- tb_ctmin + tb_ctmax - 2*topt

  # tidy data
  tpts <- tibble(tpt = c("topt", "tb", "skw", "ctmin", "ctmax", "pmax", "pmin"),
                 value = c(topt, tb, skw, ctmin, ctmax, pmax, pmin))

  return(tpts)

}

### ** Get a population's TPTs

#' Get a population's TPTs
#'
#' Gets a population's thermal-performance traits from a thermal performance dataset (TPD) with id, t, and p as variables.
#'
#' @param pop_tpd A population's TPD (id, p and t as columns)
#' @param pmin The percentage of Pmax corresponding to Pmin
#'
#' @return A tibble with id, tpt and value as columns
#'
#' @examples
#'
#' @export

get_pop_tpts <- function(pop_tpd, pmin){

  # Holder data frame
  pop_tpts <- data.frame(id = character(), Topt = logical(), Tb50 = logical(), Skw50 = logical(), Skw80 = logical(),
                         Pmax = logical(), Pmin = logical(), CTmax = logical(), CTmin = logical())

  # Nest original dataset to attest number of unique indiviudals
  pop_tpd <- pop_tpd %>% nest(tpd = c(t,p))

  # Loop to extract tpts for each individual
  for(i in 1:nrow(pop_tpd)){

    # Extract each individual id
    id <- pop_tpd %>% select(id) %>% slice(i) %>% as.data.frame()

    # Predict each indidual's TPTS
    tpts <- pop_tpd %>% select(tpd) %>% slice(i) %>% unnest(cols = c(tpd)) %>%
      as.data.frame() %>% fit_tpd() %>% gen_tpc() %>% get_tpts(.,pmin)

    # Putting it together in a data frame and rbinding it to the holder data frame
    pop_tpts <- rbind(pop_tpts, cbind(id,tpts))

  }

  return(as_tibble(pop_tpts))

}

### * Get a populations CMTX

#' Get a population's TPT correlation matrix
#'
#' Gets a matrix of correlations for a population's thermal-performance traits (TPTs)
#'
#' @param pop_tpts A population's TPTs in the format of the output of the get_pop_tpts function
#'
#' @return A matrix of correlation between TPTs
#'
#' @examples
#'
#' @export

get_corr_matrix <- function(pop_tpts){

  # get the matrix
  mtx <- suppressWarnings(pop_tpts %>% select(tpt, value) %>% filter(tpt != "pmin") %>% nest(value = c(value)) %>% spread(tpt, value) %>%
                            unnest() %>% rename(ctmax = value, ctmin = value1, pmax = value2, skw = value3, tb = value4, topt = value5) %>%
                            as.matrix() %>% rcorr())

  # extract the correlations
  mtx <- mtx$r

  return(mtx)

}