tests/testthat/pulsarfuns.R

In zdk123/pulsar: Parallel Utilities for Lambda Selection along a Regularization Path

climer <- function(data, lambda, seed=NULL) {
    est <- clime::clime(data, lambda=lambda, pdtol=1e-2)
    est$path <- lapply(est$Omegalist, function(x) {
        diag(x) <- 0
        as(abs(x)>1e-3, "lMatrix")
    })
    est
}

runtests <- function(pfun, pclass, dat, fun, fargs, ...) {
    G <- dat$theta
    test_that("bad crits results in right errors", {
        lams <- getLamPath(.7, .5, 5)
        hargs <- c(fargs, list(lambda=lams))
        expect_error(out <- pfun(dat$data, fun=fun, fargs=hargs, rep.num=2,
           criterion=c("stars", "foo"), ...), "foo")
        expect_error(out <- pfun(dat$data, fun=fun, fargs=hargs, rep.num=2,
                       criterion=c("estrada", "sufficiency"), ...))
    })

    test_that("weird lambda path results in correct error or warning", {
        lams <- seq(.5, .7, length.out=5)
        hargs <- c(fargs, list(lambda=lams))
        expect_warning(out <- pfun(dat$data, fun=fun, fargs=hargs, rep.num=3,
                       ...), "lambda path")
        expect_warning(out <- pfun(dat$data, fun=fun,
              fargs=c(list(lambda=lams[1]), fargs), rep.num=3, ...), "1 value")
        expect_error(out <- pfun(dat$data, fun=fun, fargs=c(list(lams=lams),
                fargs), rep.num=3, ...), "missing")
        expect_warning(out <- pfun(dat$data, fun=fun,
              fargs=c(list(lambda=lams[c(5,4)]), fargs), rep.num=3, ...),
               "supplied values")
    })

    mlam  <- getMaxCov(scale(dat$data))
    lams  <- getLamPath(mlam, 5e-4, 20)
    hargs <- c(fargs, list(lambda=lams))
    out   <- pfun(dat$data, fun=fun, fargs=hargs, criterion="stars", rep.num=6, ...)
    outb  <- update(out, lb.stars=TRUE, ub.stars=TRUE, criterion=c("stars", "gcd"))

    test_that("pulsar w/ lambda path works for fun", {
        ## run pulsar in serial mode
        expect_is(out, pclass)
        expect_equal(out$stars$criterion, "stars.stability")
        # stars summary is monotonic increasing
        expect_equal(out$stars$summary, cummax(out$stars$summary))
        # merge objects dims match original graph, data
        expect_true(all(sapply(out$stars$merge, function(x) all(dim(x) == dim(G)))))
        expect_true(all(sapply(out$stars$merge, function(x) all(dim(x) == ncol(dat$data)))))

    })

    test_that("pulsar bounds are consistent", {
        ## check lengths
        expect_equal(outb$gcd$criterion, "graphlet.stability")
        expect_error(fit <- refit(out, 'stars'), NA)

       # same answer using bounds
        expect_equal(outb$stars$opt.ind, out$stars$opt.ind)

        ## gcd computed between bounds
        expect_equal(length(outb$gcd$summary),
                    outb$stars$lb.index-outb$stars$ub.index+1)
        # same answer using bounds
        expect_equal(opt.index(outb, 'stars'),
                    opt.index(out, 'stars'))
        ## check F1 score is OK
        opt.index(outb, 'gcd') <- get.opt.index(outb, 'gcd')
        pdf(NULL)
        starsF1 <- huge::huge.roc(list(outb$stars$merge[[ opt.index(outb, 'stars') ]] > 0), G, verbose=FALSE)$F1
        gcdF1   <- huge::huge.roc(list(outb$stars$merge[[ opt.index(outb, 'gcd')   ]] > 0), G, verbose=FALSE)$F1
        dev.off()
        expect_gte(gcdF1, starsF1)
    })

    return(list(out=out, outb=outb))
}


runcomptest <- function(msg, out1, out2, ...) {
    test_that(msg, {
      # make sure summary isn't trivally zero
        expect_gt(max(out1$stars$summary), 0)
        expect_gt(max(out2$stars$summary), 0)
        expect_equivalent(out1$stars$summary,   out2$stars$summary)
        expect_equivalent(out1$stars$opt.index, out2$stars$opt.index)
    })
}


testrefit0 <- function(desc, out) {
    test_that(desc, {
        expect_message(fit1 <- refit(out, "stars"), regexp = NA)
        expect_equal(names(fit1$refit), "stars")
        expect_warning(fit3 <- refit(out), regexp = NA)
        expect_gt(sum(fit3$refit$stars), 0)
        expect_warning(fit4 <- refit(out, "foo"), "Unknown criterion")
    })
}

testrefit <- function(desc, outb) {
    test_that(desc, {
        expect_message(fit1 <- refit(outb, "stars"), regexp = NA)
        expect_message(fit2 <- refit(outb, "gcd"), "No optimal index")
        expect_equal(names(fit1$refit), "stars")
        expect_error(opt.index(outb, 'gcd') <- -1, "Index value")
        expect_error(opt.index(outb, 'gcd') <- get.opt.index(outb, 'gcd'), NA)
        expect_equal(opt.index(outb, 'gcd'), outb$gcd$opt.index)
        expect_equal(opt.index(outb, 'gcd'), get.opt.index(outb, 'gcd'))
        expect_warning(fit3 <- refit(outb), regexp = NA)

        expect_gte(sum(fit3$refit$stars), 0)
        expect_gte(sum(fit3$refit$gcd),   0)
        expect_warning(fit4 <- refit(outb, "foo"), "Unknown criterion")
    })
}