tests/testthat/test.MatrixComparisons.r

In evolqg: Evolutionary Quantitative Genetics

test_that("RandomSkewers returns correct results on pairs of matrices",
          {
            expect = c(correlation = 0.954184140494324, probability = 0.00561, correlation_sd = 0.0553934050116506)
            data(dentus)
            cor.matrix.1 <- cov(dentus[dentus$species=="A", 1:4])
            cor.matrix.2 <- cov(dentus[dentus$species=="B", 1:4])
            results <- RandomSkewers(cor.matrix.1, cor.matrix.2, num.vectors = 100000)
            expect_equal(results, expect, tolerance = 1e-2)
            expect_that(results, is_a("numeric"))
            expect_that(length(results), equals(3))
            expect_true(results[1] <=  1)
            expect_true(results[1] >= -1)
            expect_true(results[2] <=  1)
            expect_true(results[2] >=  0)
            expect_true(results[3] >=  0)
          }
)

test_that("RandomSkewers returns correct results on lists",
          {
            mat.list <- lapply(as.list(1:10), function(x) RandomMatrix(10))
            rep.vec <- runif(length(mat.list), 0.8, 0.9)
            suppressWarnings(RNGversion("3.5.0"))
            set.seed(42)
            results.list <- RandomSkewers(mat.list)
            expect_that(results.list, is_a("list"))
            results <- results.list[[1]]
            expect_that(sum(is.na(results)), equals(0))
            probabilities <- results.list[[2]]
            expect_that(sum(is.na(probabilities)), equals(0))
            expect_that(results.list, is_a("list"))
            suppressWarnings(RNGversion("3.5.0"))
            set.seed(42)
            results.list.2 <- RandomSkewers(mat.list, repeat.vector = rep.vec)
            results.2 <- results.list.2[[1]]
            expect_that(sum(is.na(results.2)), equals(0))
            probabilities.2 <- results.list.2[[2]]
            expect_that(dim(results), equals(c(length(mat.list),length(mat.list))))
            lower  <- results[lower.tri(results)]
            lower.bool = sapply(lower, function(x) isTRUE(x > -1 & x < 1))
            expect_that(sum(lower.bool), equals(length(lower.bool)))
            upper  <- results[upper.tri(results, diag = T)]
            upper.bool = sapply(upper, function(x) isTRUE(x == 0))
            expect_that(sum(upper.bool), equals(length(upper.bool)))
            lower.2  <- results.2[lower.tri(results.2)]
            upper.2  <- t(results.2)[lower.tri(results.2)]
            expect_that(lower.2, equals(lower))
            expect_that(diag(results.2), is_equivalent_to(rep.vec))
            expect_that(sum(upper.2 < lower.2), equals(0))
          }
)

test_that("RandomSkewers returns correct results on lists + matrices",
          {
            mat.list <- lapply(as.list(1:10), function(x) RandomMatrix(10))
            y.matrix <- RandomMatrix(10)
            suppressWarnings(RNGversion("3.5.0"))
            set.seed(42)
            results <- RandomSkewers(mat.list, y.matrix)
            expect_that(results, is_a("data.frame"))
            expect_that(sum(is.na(results)), equals(0))
            expect_that(dim(results), equals(c(length(mat.list), 3)))
            names(mat.list) <- 1:length(mat.list)
            named.results <- RandomSkewers(mat.list, y.matrix)
            expect_that(named.results, is_a("data.frame"))
            expect_that(sum(is.na(named.results)), equals(0))
            expect_that(dim(named.results), equals(c(length(mat.list), 4)))
            expect_that(named.results[,".id"], equals(names(mat.list)))
          }
)
test_that("MantelCor returns correct results on non-landmark data",
          {
            cor.matrix.1 <- RandomMatrix(15)
            cor.matrix.2 <- RandomMatrix(15)
            results <- MantelCor(cor.matrix.1, cor.matrix.2)
            expect_equivalent(results[1], cor(cor.matrix.1[lower.tri(diag(15))],
                                              cor.matrix.2[lower.tri(diag(15))]))

          })

test_that("MantelCor returns correct results on landmark data",
          {
            cor.matrix.1 <- RandomMatrix(12)
            cor.matrix.2 <- RandomMatrix(12)
            results <- MantelCor(cor.matrix.1, cor.matrix.2, landmark.dim = 2)
            expect_equivalent(results[1], cor(cor.matrix.1[evolqg:::lower.tri.land(diag(12), 2)],
                                              cor.matrix.2[evolqg:::lower.tri.land(diag(12), 2)]))
            results <- MantelCor(cor.matrix.1, cor.matrix.2, landmark.dim = 3)
            expect_equivalent(results[1], cor(cor.matrix.1[evolqg:::lower.tri.land(diag(12), 3)],
                                              cor.matrix.2[evolqg:::lower.tri.land(diag(12), 3)]))
            expect_error(MantelCor(cor.matrix.1, cor.matrix.2, landmark.dim = 4))
          })

test_that("MantelCor returns correct results on list",
          {
            mat.list <- RandomMatrix(10, 10)
            rep.vec <- runif(length(mat.list), 0.8, 0.9)
            results.list <- MantelCor(mat.list)
            results <- results.list[[1]]
            expect_equivalent(results[2,1], MantelCor(mat.list[[1]],
                                                      mat.list[[2]])[1])
            expect_equivalent(results[8,5], MantelCor(mat.list[[8]],
                                                      mat.list[[5]])[1])
            expect_that(sum(is.na(results)), equals(0))
            probabilities <- results.list[[2]]
            expect_that(sum(is.na(probabilities)), equals(0))
            expect_that(results.list, is_a("list"))
            results.list.2 <- MantelCor(mat.list, repeat.vector = rep.vec)
            results.2 <- results.list.2[[1]]
            expect_that(sum(is.na(results.2)), equals(0))
            probabilities.2 <- results.list.2[[2]]
            expect_that(dim(results), equals(c(length(mat.list),length(mat.list))))
            lower <- results[lower.tri(results)]
            lower.bool = sapply(lower, function(x) isTRUE(x > -1 & x < 1))
            expect_that(sum(lower.bool), equals(length(lower.bool)))
            upper  <- results[upper.tri(results, diag = T)]
            upper.bool = sapply(upper, function(x) isTRUE(x == 0))
            expect_that(sum(upper.bool), equals(length(upper.bool)))
            lower.2 <- results.2[lower.tri(results.2)]
            upper.2 <- t(results.2)[lower.tri(results.2)]
            expect_that(lower.2, equals(lower))
            expect_that(diag(results.2), is_equivalent_to(rep.vec))
            expect_that(sum(abs(upper.2) < abs(lower.2)), equals(0))
          }
)

test_that("MantelCor returns correct results on list for landmark data",
          {
            mat.list <- RandomMatrix(12, 10)
            rep.vec <- runif(length(mat.list), 0.8, 0.9)
            results.list <- MantelCor(mat.list, landmark.dim = 2)
            results <- results.list[[1]]
            expect_equivalent(results[2,1], MantelCor(mat.list[[1]],
                                                      mat.list[[2]], landmark.dim = 2)[1])
            expect_equivalent(results[8,5], MantelCor(mat.list[[8]],
                                                      mat.list[[5]], landmark.dim = 2)[1])
            results.list <- MantelCor(mat.list, landmark.dim = 3)
            results <- results.list[[1]]
            expect_equivalent(results[2,1], MantelCor(mat.list[[1]],
                                                      mat.list[[2]], landmark.dim = 3)[1])
            expect_equivalent(results[8,5], MantelCor(mat.list[[8]],
                                                      mat.list[[5]], landmark.dim = 3)[1])
            expect_that(sum(is.na(results)), equals(0))
            probabilities <- results.list[[2]]
            expect_that(sum(is.na(probabilities)), equals(0))
            expect_that(results.list, is_a("list"))
            results.list.2 <- MantelCor(mat.list, repeat.vector = rep.vec, landmark.dim = 3)
            results.2 <- results.list.2[[1]]
            expect_that(sum(is.na(results.2)), equals(0))
            probabilities.2 <- results.list.2[[2]]
            expect_that(dim(results), equals(c(length(mat.list),length(mat.list))))
            lower <- results[lower.tri(results)]
            lower.bool = sapply(lower, function(x) isTRUE(x > -1 & x < 1))
            expect_that(sum(lower.bool), equals(length(lower.bool)))
            upper  <- results[upper.tri(results, diag = T)]
            upper.bool = sapply(upper, function(x) isTRUE(x == 0))
            expect_that(sum(upper.bool), equals(length(upper.bool)))
            lower.2 <- results.2[lower.tri(results.2)]
            upper.2 <- t(results.2)[lower.tri(results.2)]
            expect_that(lower.2, equals(lower))
            expect_that(diag(results.2), is_equivalent_to(rep.vec))
            expect_that(sum(abs(upper.2) < abs(lower.2)), equals(0))
          }
)

test_that("MantelCor returns correct results on lists + matrices",
          {
            mat.list <- lapply(as.list(1:10), function(x) RandomMatrix(11))
            y.matrix <- RandomMatrix(11)
            suppressWarnings(RNGversion("3.5.0"))
            set.seed(42)
            results <- MantelCor(mat.list, y.matrix)
            suppressWarnings(RNGversion("3.5.0"))
            set.seed(42)
            expect_equivalent(results[1,], MantelCor(y.matrix, mat.list[[1]]))
            expect_that(results, is_a("data.frame"))
            expect_that(sum(is.na(results)), equals(0))
            expect_that(dim(results), equals(c(length(mat.list), 2)))
            names(mat.list) <- 1:length(mat.list)
            named.results <- MantelCor(mat.list, y.matrix)
            expect_that(named.results, is_a("data.frame"))
            expect_that(sum(is.na(named.results)), equals(0))
            expect_that(dim(named.results), equals(c(length(mat.list), 3)))
            expect_that(named.results[,".id"], equals(names(mat.list)))
          }
)

test_that("MantelCor returns correct results on lists + matrices for landmark data",
          {
            mat.list <- lapply(as.list(1:10), function(x) RandomMatrix(12))
            y.matrix <- RandomMatrix(12)
            suppressWarnings(RNGversion("3.5.0"))
            set.seed(42)
            results <- MantelCor(mat.list, y.matrix, landmark.dim = 2)
            suppressWarnings(RNGversion("3.5.0"))
            set.seed(42)
            expect_equivalent(results[1,], MantelCor(y.matrix, mat.list[[1]], landmark.dim = 2))
            expect_that(results, is_a("data.frame"))
            expect_that(sum(is.na(results)), equals(0))
            expect_that(dim(results), equals(c(length(mat.list), 2)))
            names(mat.list) <- 1:length(mat.list)
            named.results <- MantelCor(mat.list, y.matrix)
            expect_that(named.results, is_a("data.frame"))
            expect_that(sum(is.na(named.results)), equals(0))
            expect_that(dim(named.results), equals(c(length(mat.list), 3)))
            expect_that(named.results[,".id"], equals(names(mat.list)))
          }
)

test_that("KrzCor returns correct results",
          {
              cov.matrix.1 <- RandomMatrix(10)
              cov.matrix.2 <- RandomMatrix(10)
              ret.dim = round(dim(cov.matrix.1)[1]/2 - 1)
              EigenVectors <- function (x) return (eigen(x)$vectors[,1:ret.dim])
              A <- EigenVectors (cov.matrix.1)
              B <- EigenVectors (cov.matrix.2)
              S <- t(A) %*% B %*% t(B) %*% A
              SL <- sum (eigen(S)$values) / ret.dim
              expect_that(KrzCor(cov.matrix.1, cov.matrix.2), is_equivalent_to(SL))
              expect_that(KrzCor(cov.matrix.1, cov.matrix.2, 10), is_equivalent_to(1))
              expect_that(KrzCor(x  <- RandomMatrix(11), x), is_equivalent_to(1))
              expect_true(KrzCor(cov.matrix.1, cov.matrix.2) <= 1)
              expect_true(KrzCor(cov.matrix.1, cov.matrix.2) > 0)
          }
)

test_that("KrzCor returns correct results",
          {
            mat.list <- lapply(as.list(1:10), function(x) RandomMatrix(10))
            rep.vec <- runif(length(mat.list), 0.8, 0.9)
            results <- KrzCor(mat.list)
            expect_equivalent(results[2,1], KrzCor(mat.list[[1]], mat.list[[2]]))
            results.2 <- KrzCor(mat.list, repeat.vector = rep.vec)
            expect_that(sum(is.na(results)), equals(0))
            expect_that(sum(is.na(results.2)), equals(0))
            expect_that(dim(results), equals(c(length(mat.list),length(mat.list))))
            lower  <- results[lower.tri(results)]
            lower.bool = sapply(lower, function(x) isTRUE(x > 0 & x < 1))
            expect_that(sum(lower.bool), equals(length(lower.bool)))
            upper  <- results[upper.tri(results, diag = T)]
            upper.bool = sapply(upper, function(x) isTRUE(x == 0))
            expect_that(sum(upper.bool), equals(length(upper.bool)))
            lower.2  <- results.2[lower.tri(results.2)]
            upper.2  <- t(results.2)[lower.tri(results.2)]
            expect_that(lower.2, equals(lower))
            expect_that(diag(results.2), is_equivalent_to(rep.vec))
            expect_that(sum(upper.2 < lower.2), equals(0))
          }
)

test_that("KrzCor returns correct results on lists + matrices",
          {
            mat.list <- lapply(as.list(1:10), function(x) RandomMatrix(13))
            y.matrix <- RandomMatrix(13)
            results <- KrzCor(mat.list, y.matrix)
            expect_equivalent(results[1], KrzCor(mat.list[[1]], y.matrix))
            expect_that(results, is_a("numeric"))
            expect_that(sum(is.na(results)), equals(0))
            expect_that(length(results), equals(length(mat.list)))
            names(mat.list) <- 1:length(mat.list)
            named.results <- KrzCor(mat.list, y.matrix)
            expect_that(named.results, is_a("data.frame"))
            expect_that(sum(is.na(named.results)), equals(0))
            expect_that(dim(named.results), equals(c(length(mat.list), 2)))
            expect_that(named.results[,".id"], equals(names(mat.list)))
          }
)

test_that("KrzProjection returns correct results on matrices",
          {
            suppressWarnings(RNGversion("3.5.0"))
            set.seed(17)
            cov.matrix.1 <- RandomMatrix(10, LKJ = FALSE)
            cov.matrix.2 <- RandomMatrix(10, LKJ = FALSE)
            expect_that(KrzProjection(cov.matrix.1, cov.matrix.2), is_a("list"))
            expect_that(length(KrzProjection(cov.matrix.1, cov.matrix.2)), equals(2))
            expect_that(length(KrzProjection(cov.matrix.1,
                                             cov.matrix.2,
                                             ret.dim.1 = 3)[[2]]),
                        equals(3))
            expect_that(length(KrzProjection(cov.matrix.1,
                                             cov.matrix.2,
                                             ret.dim.1 = 5)[[2]]),
                        equals(5))
            expect_that(length(KrzProjection(cov.matrix.1,
                                             cov.matrix.2,
                                             ret.dim.2 = 10)[[2]]),
                        equals(4))
            expect_that(KrzProjection(cov.matrix.1,
                                      cov.matrix.2,
                                      ret.dim.1 = 10, ret.dim = 10)[[1]],
                        equals(1))
            per.PC <- KrzProjection(cov.matrix.1, cov.matrix.2, ret.dim.1 = 10, ret.dim = 10)[[2]]
            ones = sapply(per.PC, function(x) isTRUE(all.equal(x, 1)))
            expect_that(sum(ones), equals(10))
          }
)

test_that("KrzProjection returns correct results on lists",
          {
            suppressWarnings(RNGversion("3.5.0"))
            set.seed(170)
            mat.list <- RandomMatrix(10, 10, LKJ = FALSE)
            expect_that(dim(KrzProjection(mat.list)), equals(c(length(mat.list), length(mat.list))))
            expect_that(KrzProjection(mat.list)[1,2], equals(KrzProjection(mat.list[[1]], mat.list[[2]])[[1]]))
            expect_that(KrzProjection(mat.list)[2,1], equals(KrzProjection(mat.list[[2]], mat.list[[1]])[[1]]))
            expect_that(length(KrzProjection(mat.list, full.results = T)), equals(length(mat.list)))
            expect_that(KrzProjection(mat.list, full.results = T), is_a("list"))
          }
)

test_that("KrzProjection returns correct results on lists and matrices",
          {
            mat.list <- RandomMatrix(10, 10)
            results <- KrzProjection(mat.list, mat.list[[1]])
            test.results <- KrzProjection(mat.list)[,1]
            expect_that(results, is_a('data.frame'))
            expect_that(results[[1]], is_equivalent_to(test.results))
          }
)

test_that("PCAsimilarity returns correct results",
          {
            cov.matrix.1 <- RandomMatrix(10)
            cov.matrix.2 <- RandomMatrix(10)
            eg.x <- eigen(cov.matrix.1)
            eg.y <- eigen(cov.matrix.2)
            eg.x.values <- eg.x$values
            eg.y.values <- eg.y$values
            eg.x.vectors <- eg.x$vectors
            eg.y.vectors <- eg.y$vectors

            total_var <- eg.x.values %*% eg.y.values

            SL = sum((eg.x.values %o% eg.y.values) * ((t(eg.x.vectors) %*% (eg.y.vectors))**2))/total_var
            expect_that(PCAsimilarity(cov.matrix.1, cov.matrix.2), is_equivalent_to(SL))
            expect_that(PCAsimilarity(x  <- RandomMatrix(11), x), is_equivalent_to(1))
            expect_true(PCAsimilarity(cov.matrix.1, cov.matrix.2) <= 1)
            expect_true(PCAsimilarity(cov.matrix.1, cov.matrix.2) > 0)
          }
)

test_that("PCAsimilarity returns correct results",
          {
            mat.list <- lapply(as.list(1:10), function(x) RandomMatrix(10))
            rep.vec <- runif(length(mat.list), 0.8, 0.9)
            results <- PCAsimilarity(mat.list)
            expect_equivalent(results[2,1], PCAsimilarity(mat.list[[1]], mat.list[[2]]))
            results.2 <- PCAsimilarity(mat.list, repeat.vector = rep.vec)
            expect_that(sum(is.na(results)), equals(0))
            expect_that(sum(is.na(results.2)), equals(0))
            expect_that(dim(results), equals(c(length(mat.list),length(mat.list))))
            lower  <- results[lower.tri(results)]
            lower.bool = sapply(lower, function(x) isTRUE(x > 0 & x < 1))
            expect_that(sum(lower.bool), equals(length(lower.bool)))
            upper  <- results[upper.tri(results, diag = T)]
            upper.bool = sapply(upper, function(x) isTRUE(x == 0))
            expect_that(sum(upper.bool), equals(length(upper.bool)))
            lower.2  <- results.2[lower.tri(results.2)]
            upper.2  <- t(results.2)[lower.tri(results.2)]
            expect_that(lower.2, equals(lower))
            expect_that(diag(results.2), is_equivalent_to(rep.vec))
            expect_that(sum(upper.2 < lower.2), equals(0))
          }
)

test_that("PCAsimilarity returns correct results on lists + matrices",
          {
            mat.list <- lapply(as.list(1:10), function(x) RandomMatrix(13))
            y.matrix <- RandomMatrix(13)
            results <- PCAsimilarity(mat.list, y.matrix)
            expect_equivalent(results[1], PCAsimilarity(mat.list[[1]], y.matrix))
            expect_that(results, is_a("numeric"))
            expect_that(sum(is.na(results)), equals(0))
            expect_that(length(results), equals(length(mat.list)))
            names(mat.list) <- 1:length(mat.list)
            named.results <- PCAsimilarity(mat.list, y.matrix)
            expect_that(named.results, is_a("data.frame"))
            expect_that(sum(is.na(named.results)), equals(0))
            expect_that(dim(named.results), equals(c(length(mat.list), 2)))
            expect_that(named.results[,".id"], equals(names(mat.list)))
          }
)