tests/testthat/test-lmm.R

In rqtl/qtl2: Quantitative Trait Locus Mapping in Experimental Crosses

context("linear mixed models")

set.seed(20151124)
n <- 100
x <- matrix(rnorm(20*n), ncol=20)
k <- as.matrix(-dist(x))
k <- (k-min(k))/(max(k)-min(k))
dimnames(k) <- NULL

X <- cbind(1, sample(0:1, n, replace=TRUE))
d <- chol(0.25*k + diag(rep(0.75, n)))
y <- as.numeric(matrix(rnorm(n), nrow=1) %*% d) + X %*% c(1, 2)


test_that("eigen decomposition works", {

    e <- Rcpp_eigen_decomp(k)

    # same determinants?
    expect_equal(sum(log(e$values)), sum(log(eigen(k)$values)))

    # multiply back
    expect_equal(t(e$vectors) %*% diag(e$values) %*% e$vectors, k)

    # inverse
    expect_equal(t(e$vectors) %*% diag(1/e$values) %*% e$vectors, solve(k))

})

test_that("eigen + rotation works", {

    e <- Rcpp_eigen_rotation(k, y, X)

    # rotate back
    expect_equal(t(e$Kve_t) %*% e$y, y)
    expect_equal(t(e$Kve_t) %*% e$X, X)

    # same determinants?
    expect_equal(sum(log(e$Kva)), sum(log(eigen(k)$values)))

    # multiply back
    expect_equal(t(e$Kve_t) %*% diag(e$Kva) %*% e$Kve_t, k)

    # inverse
    expect_equal(t(e$Kve_t) %*% diag(1/e$Kva) %*% e$Kve_t, solve(k))

})

test_that("fitLMM works", {

    expected_reml <- list(loglik = -217.595158548486,
                          hsq = 0.0367120313458048,
                          sigmasq = 0.79659576062727,
                          beta = c(0.886161208390094, 1.74687862579568))

    expected_ml <- list(loglik = -217.180784548857,
                        hsq = 0,
                        sigmasq = 0.769853921083333,
                        beta = c(0.887111992802203, 1.74121566369042))

    e <- Rcpp_eigen_rotation(k, y, X)
    expect_equal(Rcpp_fitLMM(e$Kva, e$y, e$X), expected_reml)
    expect_equal(Rcpp_fitLMM(e$Kva, e$y, e$X, FALSE), expected_ml)

})