tests/testthat/test_linpred.R

In kenkellner/ubms: Bayesian Models for Data from Unmarked Animals using 'Stan'

context("Get posterior of linear predictor")

skip_on_cran()

#Setup umf
set.seed(123)
sc <- data.frame(x1=rnorm(3), x2=factor(c("a","b","c")))
oc <- data.frame(x3=rnorm(9))
umf <- unmarkedFrameOccu(y=matrix(c(1,0,0,1,1,0,0,1,0), nrow=3),
        siteCovs=sc, obsCovs=oc)
#Fit model
good_fit <- TRUE
tryCatch({
fit <- suppressWarnings(stan_occu(~x3~x1+(1|x2), umf,
                                  chains=2, iter=40, refresh=0))
}, error=function(e){
  good_fit <<- FALSE
})
skip_if(!good_fit, "Test setup failed")

test_that("predict correctly wraps sim_lp",{
  expect_error(predict(fit, "fake"))
  pr <- predict(fit, "state")
  expect_is(pr, "data.frame")
  expect_equal(names(pr), c("Predicted","SD","2.5%","97.5%"))
  expect_equal(dim(pr), c(3,4))

  #Newdata
  nd <- data.frame(x1=0)
  #Missing random effect
  expect_error(predict(fit, "state", newdata=nd))
  #Should work now
  pr2 <- predict(fit, "state", newdata=nd, re.form=NA)
  expect_is(pr2, "data.frame")
  expect_equal(dim(pr2), c(1,4))
  #Change level
  pr3 <- predict(fit, "state", newdata=nd, re.form=NA, level=0.8)
  expect_equal(names(pr3)[3:4], c("10%","90%"))
})

test_that("posterior_linpred correctly wraps sim_lp",{
  expect_error(posterior_linpred(fit, "fake"))
  expect_equal(posterior_linpred(fit, FALSE,"state",NULL,
                                 NULL,NULL),
               sim_lp(fit,"state",FALSE,NULL,1:40,NULL))
  #Check that smaller number of draws works
  set.seed(123)
  pl <- posterior_linpred(fit, FALSE,"state",NULL,draws=3,NULL)
  set.seed(123)
  lp <- sim_lp(fit,"state",FALSE,NULL,get_samples(fit,3),NULL)
  expect_equal(pl, lp)
})

test_that("sim_lp generates posterior correctly",{
  #For all iterations
  samp <- get_samples(fit, NULL)
  lp <- sim_lp(fit, "state", transform=FALSE, newdata=NULL,
               samp, re.form=NULL)
  expect_is(lp, "matrix")
  expect_equal(dim(lp), c(40,3))

  #For a few iterations
  samp <- c(1,2,3)
  lp <- sim_lp(fit, "state", transform=FALSE, newdata=NULL,
               samp, re.form=NULL)
  expect_is(lp, "matrix")
  expect_equal(dim(lp), c(3,3))
})

test_that("sim_lp transforms parameters correctly",{

  samp <- c(1,2,3)
  lp <- sim_lp(fit, "state", transform=FALSE, newdata=NULL,
               samp, re.form=NULL)

  lpt_compare <- do.call(fit["state"]@link, list(lp))

  lpt  <- sim_lp(fit, "state", transform=TRUE, newdata=NULL,
               samp, re.form=NULL)
  expect_equal(lpt, lpt_compare)
})

test_that("sim_lp can remove random effects from linear predictor",{
  samp <- c(1,2,3)
  lp_rand <- sim_lp(fit, "state", transform=FALSE, newdata=NULL,
               samp, re.form=NULL)
  lp_norand <- sim_lp(fit, "state", transform=FALSE, newdata=NULL,
               samp, re.form=NA)
  expect_equal(dim(lp_norand), dim(lp_rand))
  expect_true(all(lp_rand != lp_norand))

  #Unchanged when submodel has no random effects
  lp_rand <- sim_lp(fit, "det", transform=FALSE, newdata=NULL,
               samp, re.form=NULL)
  lp_norand <- sim_lp(fit, "det", transform=FALSE, newdata=NULL,
               samp, re.form=NA)
  expect_equal(dim(lp_norand), dim(lp_rand))
  expect_equal(lp_rand, lp_norand)
})

test_that("sim_lp handles newdata",{
  nd <- data.frame(x1=c(0,1))
  samp <- c(1,2,3)
  #Missing covariate
  expect_error(sim_lp(fit, "state", transform=FALSE, newdata=nd,
               samp, re.form=NULL))

  nd$x2 <- factor(c("a","b"), levels=c("a","b","c"))
  lp <- sim_lp(fit,"state",transform=FALSE, newdata=nd, samp,
               re.form=NULL)
  expect_equal(dim(lp), c(3,2))
})