tests/testthat/test-control.R

In glmmTMB: Generalized Linear Mixed Models using Template Model Builder

stopifnot(require("testthat"),
          require("glmmTMB"))

## Some selected L1-distances between two fits
distFits <- function(fit1, fit2) {
    s1 <- summary(fit1)
    s2 <- summary(fit2)
    glmmTMB:::namedList(
        max(abs((coef(s1)$cond - coef(s2)$cond)[,"Estimate"])),
        max(abs((coef(s1)$cond - coef(s2)$cond)[,"Std. Error"])),
        abs(logLik(fit1) - logLik(fit2))
    )
}

test_that("profile method", {
  skip_on_cran()
    myfit <- function(...) {
        glmmTMB(count ~ mined * spp + (1|site),
                family = poisson,
                data = Salamanders,
                control = glmmTMBControl(...))
    }

    m1 <- myfit( profile=FALSE )
    m2 <- myfit( profile=TRUE  )

    expect_true( all( distFits(m1, m2) < c(1e-4, 1e-2, 1e-4) ) )

    ## ###########################################################

    myfit <- function(...) {
        glmmTMB(count ~ mined * spp + (1|site),
                zi = ~ (1 | spp),
                family = poisson,
                data = Salamanders,
                control = glmmTMBControl(...))
    }

    m1 <- myfit( profile=FALSE )
    m2 <- myfit( profile=TRUE  )

    expect_true( all( distFits(m1, m2) < c(1e-4, 1e-2, 1e-4) ) )
})




test_that("parallel regions", {

  skip_on_cran()

  myfit <- function(...) {
    glmmTMB(count ~ mined * spp + (1|site),
            family = poisson,
            data = Salamanders,
            verbose = FALSE,
            control = glmmTMBControl(...))
  }

  # Record time and model
  capture_time_model <- function(...) {
    start_time <- Sys.time()
    model <- myfit(...)
    end_time <- Sys.time()
    return(list(model = model,
                elapsed_time = end_time - start_time  ))
  }


  m1 <- capture_time_model( parallel = 1 )
  ## DON'T grab all cores - bad on large machines
  ## FIXME: check if parallel setting is persistent ???
  m2 <- capture_time_model( parallel = min(4, parallel::detectCores()  ))

  expect_true( all( distFits(m1[[1]], m2[[1]]) < c(1e-4, 1e-2, 1e-4) ) )

  # expect_true( m1[[2]] <= m2[[2]])
  

})

m1 <- glmmTMB(count ~ mined + (1|site), family = poisson, data = Salamanders)

test_that("autopar-only parallel", {
    m2 <- update(m1, control = glmmTMBControl(parallel = list(autopar = TRUE)))
    expect_equal(fixef(m1), fixef(m2))
})

get_parcore_output <- function(parallel_arg) {
    options(glmmTMB_openmp_debug = TRUE)
    cc <- capture.output(
        fit <- update(m1,
                      control = glmmTMBControl(parallel = parallel_arg))
    )
    options(glmmTMB_openmp_debug = FALSE)
    cc <- grep("NULL", cc, invert = TRUE, value = TRUE)
    n <- as.integer(gsub("\\D*(\\d+)\\D*", "\\1", cc[1], perl = TRUE))
    ap <- as.logical(gsub(".* autopar = (.*)", "\\1", cc[1], perl = TRUE))
    return(list(n = n, autopar = ap))
}

test_that("ncores/autopar argument handling", {
    ap0 <- getOption("glmmTMB.autopar", get_autopar())
    expect_equal(get_parcore_output(list(n = 2, autopar = TRUE)),
                 list(n=2L, autopar=TRUE))
    expect_equal(get_parcore_output(list(2, autopar = TRUE)),
                                    list(n=2L, autopar=TRUE))
    expect_equal(get_parcore_output(2),
                 list(n = 2L, autopar = ap0))
    expect_equal(get_parcore_output(list(n = 2)),
                 list(n = 2L, autopar = ap0))
})