tests/testthat/test_weights.R

In slouch: Stochastic Linear Ornstein-Uhlenbeck Comparative Hypotheses

context("Assertions for regimeweights")
## Tests weightmatrix
concat.factor <- function(...){
  as.factor(do.call(c, lapply(list(...), as.character)))
}

library(ape)
set.seed(15)
n <- 85

phy <- rtree(n)
regimes_tip <- sample(c("A", "B"), n, replace = TRUE)

ans <- ace(regimes_tip, phy, type = "discrete")
regimes_internal <- factor(colnames(ans$lik.anc))[apply(ans$lik.anc, 1, which.max)]

regimes <- concat.factor(regimes_tip, regimes_internal)

lineages <- lapply(1:n, function(e) lineage.constructor(phy, e, regimes, anc_maps = "regimes"))


alphas <- c(0, 1, 15, 30000000000)

naive_regweightshelper <- function(a, nt){
  res <- c(vapply(head(seq_along(nt), -1),
                  function(i) exp(-a*(nt[1] - nt[i])) - exp(-a*(nt[1] - nt[i + 1])), FUN.VALUE = 0),
           exp(-a*nt[1]) ## Theta0\Ya
  )
  return(res)
}


for (a in alphas){
  old <- lapply(lineages, function(lineage) naive_regweightshelper(a, lineage$times))
  new <- lapply(lineages, function(lineage) weights_segments(a, lineage))
  
  test_that(paste("Regimeweights for alpha =", a), {
    expect_equal(old, new)
  })
  test_that(paste("Coef sum to one for alpha =", a), {
    sum_coef <- lapply(new, sum)
    expect_equal(sum_coef, as.list(rep(1,n)))
  })
}