tests/testthat/test-drop_depcols.R

In qtl2: Quantitative Trait Locus Mapping in Experimental Crosses

context("drop linearly dependent columns")

test_that("find_lin_indep_cols works", {

    set.seed(20151130)
    x <- cbind(1, sample(0:1, 200, repl=TRUE))

    expect_equal(sort(find_lin_indep_cols(x)), c(1,2))
    expect_equal(sort(find_lin_indep_cols(cbind(x, 1))), c(1,2))
    expect_equal(sort(find_lin_indep_cols(cbind(x, x[,1] + 0.5*x[,2]))), c(2,3))

    X <- matrix(rnorm(1000*10), ncol=10)
    expect_equal(sort(find_lin_indep_cols(X)), 1:10)
    expect_equal(length(find_lin_indep_cols(cbind(rowSums(X), X))), 10)

})

test_that("drop_depcols works", {

    set.seed(20151130)
    n.ind <- 100
    x <- cbind(1,
               sample(0:1, n.ind, replace=TRUE),
               sample(0:1, n.ind, replace=TRUE))

    expect_equal(drop_depcols(NULL), NULL)
    expect_equal(drop_depcols(x), x)
    for(i in 1:ncol(x))
        expect_equal(drop_depcols(x[,i]), x[,i,drop=FALSE])

    X <- cbind(rowSums(x), x)
    expect_equal(ncol(drop_depcols(X)), 3)

})

test_that("drop_xcovar works", {

    set.seed(20151202)
    n <- 100
    Xcovar <- sample(0:1, n, replace=TRUE)
    int <- rep(1, n)
    names(Xcovar) <- names(int) <- paste(1:n)

    expect_equal( drop_xcovar(NULL, NULL), NULL)
    expect_equal( drop_xcovar(NULL, Xcovar), Xcovar)
    expect_equal( drop_xcovar(int, NULL), NULL)
    expect_equal( drop_xcovar(int, Xcovar), as.matrix(Xcovar))
    expect_equal( drop_xcovar(Xcovar, Xcovar), NULL)
    expect_equal( drop_xcovar(cbind(int, Xcovar), Xcovar), NULL)
    expect_equal( drop_xcovar(cbind(Xcovar, int), Xcovar), NULL)

    pgm <- sample(0:1, n, replace=TRUE)
    names(pgm) <- paste(1:n)
    Xcovar <- cbind(Xcovar, pgm)

    expect_equal( drop_xcovar(NULL, Xcovar), Xcovar)
    expect_equal( drop_xcovar(int, Xcovar), Xcovar)
    expect_equal( drop_xcovar(Xcovar, Xcovar), NULL)
    expect_equal( drop_xcovar(cbind(int, Xcovar), Xcovar), NULL)
    expect_equal( drop_xcovar(cbind(int, Xcovar[,1]), Xcovar), Xcovar[,2,drop=FALSE])
    expect_equal( drop_xcovar(cbind(int, Xcovar[,2]), Xcovar), Xcovar[,1,drop=FALSE])
    expect_equal( drop_xcovar(cbind(Xcovar, int), Xcovar), NULL)
    expect_equal( drop_xcovar(cbind(Xcovar[,1], int), Xcovar), Xcovar[,2,drop=FALSE])
    expect_equal( drop_xcovar(cbind(Xcovar[,2], int), Xcovar), Xcovar[,1,drop=FALSE])

})

test_that("drop_xcovar works with NAs", {

    set.seed(20151202)
    n <- 100
    Xcovar <- sample(0:1, n, replace=TRUE)
    int <- rep(1, n)
    names(Xcovar) <- names(int) <- paste(1:n)
    Xcovar[3:5] <- NA

    expect_equal( drop_xcovar(NULL, Xcovar), Xcovar)
    expect_equal( drop_xcovar(int, Xcovar), as.matrix(Xcovar))
    expect_equal( drop_xcovar(Xcovar, Xcovar), NULL)
    expect_equal( drop_xcovar(cbind(int, Xcovar), Xcovar), NULL)
    expect_equal( drop_xcovar(cbind(Xcovar, int), Xcovar), NULL)

    # try some permutations
    o <- sample(1:n)
    expect_equal( drop_xcovar(int, Xcovar[o]), as.matrix(Xcovar[o]))
    expect_equal( drop_xcovar(Xcovar, Xcovar[o]), NULL)
    expect_equal( drop_xcovar(cbind(int, Xcovar), Xcovar[o]), NULL)
    expect_equal( drop_xcovar(cbind(Xcovar, int), Xcovar[o]), NULL)

    # multiple X covar columns
    pgm <- sample(0:1, n, replace=TRUE)
    names(pgm) <- paste(1:n)
    Xcovar <- cbind(Xcovar, pgm)

    expect_equal( drop_xcovar(NULL, Xcovar), Xcovar)
    expect_equal( drop_xcovar(int, Xcovar), Xcovar)
    expect_equal( drop_xcovar(Xcovar, Xcovar), NULL)
    expect_equal( drop_xcovar(cbind(int, Xcovar), Xcovar), NULL)
    expect_equal( drop_xcovar(cbind(int, Xcovar[,1]), Xcovar), Xcovar[,2,drop=FALSE])
    expect_equal( drop_xcovar(cbind(int, Xcovar[,2]), Xcovar), Xcovar[,1,drop=FALSE])
    expect_equal( drop_xcovar(cbind(Xcovar, int), Xcovar), NULL)
    expect_equal( drop_xcovar(cbind(Xcovar[,1], int), Xcovar), Xcovar[,2,drop=FALSE])
    expect_equal( drop_xcovar(cbind(Xcovar[,2], int), Xcovar), Xcovar[,1,drop=FALSE])

    # try some permutations
    o <- sample(1:n)
    expect_equal( drop_xcovar(int, Xcovar[o,]), Xcovar[o,])
    expect_equal( drop_xcovar(Xcovar, Xcovar[o,]), NULL)
    expect_equal( drop_xcovar(cbind(int, Xcovar), Xcovar[o,]), NULL)
    expect_equal( drop_xcovar(cbind(Xcovar, int), Xcovar[o,]), NULL)
    expect_equal( drop_xcovar(cbind(int, Xcovar[,1]), Xcovar[o,]), Xcovar[o,2,drop=FALSE])
    expect_equal( drop_xcovar(cbind(int, Xcovar[,2]), Xcovar[o,]), Xcovar[o,1,drop=FALSE])
    expect_equal( drop_xcovar(cbind(Xcovar, int), Xcovar[o,]), NULL)
    expect_equal( drop_xcovar(cbind(Xcovar[,1], int), Xcovar[o,]), Xcovar[o,2,drop=FALSE])
    expect_equal( drop_xcovar(cbind(Xcovar[,2], int), Xcovar[o,]), Xcovar[o,1,drop=FALSE])

})

test_that("Fixed issue 22 re drop_depcols ", {

    # https://github.com/rqtl/qtl2/issues/22
    # ...case where indicators for all categories included

    # create example
    n_per <- 20
    n_group <- 4
    n <- n_per*n_group
    group <- rep(1:n_group, each=n_per)
    covar <- cbind(sex=rep(0:1,n_per*n_group),
                   diet=sample(100:200, n, replace=TRUE))
    for(i in 1:n_group)
        covar <- cbind(covar, (group==i)*1)
    colnames(covar)[-(1:2)] <- paste0("group", 1:n_group)

    # drop dependent columns
    covar_indep <- drop_depcols(covar, TRUE)

    # check that one of the groups got dropped
    expect_true("sex" %in% colnames(covar_indep))
    expect_true("diet" %in% colnames(covar_indep))
    expect_true(ncol(covar_indep) == ncol(covar)-1)

})