tests/testthat/test.KrzSubspace.r

In evolqg: Evolutionary Quantitative Genetics

test_that("KrzSubspace returns correct results",{
  kr.subspace_aguirre_bench <- function(Gs, vec){
    if (dim(Gs)[[1]] != dim(Gs)[[2]]){
      stop("G array must be of order n x n x m x MCMCsamp")
    }
    if (is.na(dim(Gs)[4])) {
      stop("There are no MCMCsamples")
    }
    n <- dim(Gs)[[1]]
    m <- dim(Gs)[[3]]
    MCMCsamp <- dim(Gs)[[4]] 
    if(length(vec) != m){stop("vec must have length = m")}
    h <- function (g, v){
      AA <- array(, c(n, n, m))  
      for (k in 1:m){
        g.vec <- eigen(g[,,k])$vectors[,1:(v[k])] 
        AA[,,k] <- g.vec %*% t(g.vec)
      }
      H <- apply(AA, 1:2, sum)
      list(H = H, AA = AA)
    }
    #internal function to calculate AA and H
    MCMC.H <- array(, c(n, n, MCMCsamp))
    dimnames(MCMC.H) <- list(dimnames(Gs)[[1]], dimnames(Gs)[[1]], dimnames(Gs)[[4]])      
    MCMC.AA <- array(, c(n, n, m, MCMCsamp))
    dimnames(MCMC.AA) <- list(dimnames(Gs)[[1]], dimnames(Gs)[[1]], dimnames(Gs)[[3]], dimnames(Gs)[[4]])
    for (i in 1:MCMCsamp){
      kr <- h(Gs[,,,i], v = vec)
      MCMC.H[,,i] <- kr$H
      MCMC.AA[,,,i] <- kr$AA
    }	
    #calculate AA and H for the ith MCMC sample of the G array		
    avH <- apply(MCMC.H, 1:2, mean)
    rownames(avH) <- dimnames(Gs)[[1]]
    colnames(avH) <- dimnames(Gs)[[1]]
    #calculate the posterior mean H
    avAA <- apply(MCMC.AA, 1:3, mean)
    dimnames(avAA) <- list(dimnames(Gs)[[1]], dimnames(Gs)[[1]], dimnames(Gs)[[3]])
    #calculate the posterior mean AA
    avH.vec <- eigen(avH)$vectors
    #eigenanalysis of posterior mean H	
    proj<- function(a, b) t(b) %*% a %*% b
    #internal function to do projection
    avH.theta <- matrix(, n, m)
    for (i in 1:n){
      for (i in 1:n){
        avH.theta[i,] <- acos(sqrt(apply(avAA, 3, proj, b = avH.vec[,i]))) * (180/pi)
      }
    }
    #angles between the eigenvectors posterior mean H and the posterior mean subspaces of each population
    MCMC.H.val <- matrix(, MCMCsamp, n)
    colnames(MCMC.H.val) <- paste("h", 1:n, sep="")
    for (i in 1:n){
      MCMC.H.val[,i] <- apply(MCMC.H, 3, proj, b = avH.vec[,i])
    }
    #posterior distribution of the genetic variance for the eigenvectors of posterior mean H 
    MCMC.H.theta <- array(, c(n, m, MCMCsamp))
    rownames(MCMC.H.theta) <- paste("h", 1:n, sep="")
    colnames(MCMC.H.theta) <- dimnames(Gs)[[3]]
    for(i in 1:n){
      for(j in 1:MCMCsamp){
        MCMC.H.theta[i,,j] <- acos(sqrt(apply(MCMC.AA[,,,j], 3, proj, b = avH.vec[,i]))) * (180/pi)
      }
    }
    #posterior distribution of the angles between the eigenvectors of posterior mean H and the MCMC samples of the subspaces of each population
    list(avAA = avAA, avH = avH, MCMC.AA = MCMC.AA, MCMC.H = MCMC.H, MCMC.H.val = MCMC.H.val, MCMC.H.theta = MCMC.H.theta)
  }
  cov.matrices = aperm(aaply(1:10, 1, function(x) laply(RandomMatrix(6, 40, variance = runif(6,1, 10)), 
                                                        identity)), c(3, 4, 1, 2))
  Hs = llply(alply(cov.matrices, 4, function(x) alply(x, 3)), function(x) KrzSubspace(x, 3)$H)
  avgH = Reduce("+", Hs)/length(Hs)
  avgH.vec <- eigen(avgH)$vectors
  MCMC.H.val = laply(Hs, function(mat) diag(t(avgH.vec) %*% mat %*% avgH.vec))
  x = kr.subspace_aguirre_bench(cov.matrices, vec = rep(3, 10))
  expect_that(HPDinterval(as.mcmc(x$MCMC.H.val)), is_equivalent_to(HPDinterval(as.mcmc(MCMC.H.val))))
})