diff --git a/codecov.yml b/codecov.yml index 04c5585..fb44e4a 100644 --- a/codecov.yml +++ b/codecov.yml @@ -1,3 +1,5 @@ +codecov: + token: ee7b2b5a-89b2-4464-bc1f-a87d69ebf9b8 comment: false coverage: diff --git a/tests/testthat/test-intMsPGOcc.R b/tests/testthat/test-intMsPGOcc.R new file mode 100644 index 0000000..8586683 --- /dev/null +++ b/tests/testthat/test-intMsPGOcc.R @@ -0,0 +1,860 @@ +# test-intMsPGOcc.R ------------------------------------------------------- +skip_on_cran() + +# Intercept only ---------------------------------------------------------- +# Simulate data ----------------------------------------------------------- +set.seed(883) +J.x <- 10 +J.y <- 10 +# Total number of data sources across the study region +J.all <- J.x * J.y +# Number of data sources. +n.data <- 3 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +n.rep <- list() +# for (i in 1:n.data) { +# n.rep[[i]] <- sample(1:4, size = J.obs[i], replace = TRUE) +# } +n.rep[[1]] <- sample(1, size = J.obs[1], replace = TRUE) +n.rep[[2]] <- sample(2, size = J.obs[2], replace = TRUE) +n.rep[[3]] <- sample(3, size = J.obs[3], replace = TRUE) + +N <- c(7, 4, 5) + +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.4) +# Detection +# Detection covariates +alpha.mean <- list() +tau.sq.alpha <- list() +p.det.long <- c(1, 1, 1) + +for (i in 1:n.data) { + alpha.mean[[i]] <- runif(p.det.long[i], -1, 1) + tau.sq.alpha[[i]] <- runif(p.det.long[i], 0.1, 1) +} +p.det <- sum(p.det.long) + +# Random effects +psi.RE <- list() +# Not currently supported +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = max(N), ncol = p.occ) +for (i in 1:p.occ) { + beta[, i] <- rnorm(max(N), beta.mean[i], sqrt(tau.sq.beta[i])) +} +alpha <- list() +for (i in 1:n.data) { + alpha[[i]] <- matrix(NA, nrow = N[i], ncol = p.det.long[i]) + for (t in 1:p.det.long[i]) { + alpha[[i]][, t] <- rnorm(N[i], alpha.mean[[i]][t], sqrt(tau.sq.alpha[[i]])[t]) + } +} +sp <- FALSE +factor.model <- FALSE + +dat <- simIntMsOcc(n.data = n.data, J.x = J.x, J.y = J.y, + J.obs = J.obs, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = sp, factor.model = factor.model) + +J <- nrow(dat$coords.obs) +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +X.re <- dat$X.re.obs +X.p.re <- dat$X.p.re +sites <- dat$sites +species <- dat$species + +# Package all data into a list +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +#colnames(occ.covs) <- c('occ.cov') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int = X.p[[1]][, , 1]) +det.covs[[2]] <- list(int = X.p[[2]][, , 1]) +det.covs[[3]] <- list(int = X.p[[3]][, , 1]) + +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + species = species) + +prior.list <- list(beta.comm.normal = list(mean = 0, + var = 2.73), + alpha.comm.normal = list(mean = list(0, 0, 0), + var = list(2.73, 2.73, 2.73)), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = list(0.1, 0.1, 0.1), + b = list(0.1, 0.1, 0.1))) +inits.list <- list(alpha.comm = list(0, 0, 0), + beta.comm = 0, + tau.sq.beta = 1, + tau.sq.alpha = list(1, 1, 1), + alpha = list(a = matrix(rnorm(p.det.long[1] * N[1]), N[1], p.det.long[1]), + b = matrix(rnorm(p.det.long[2] * N[2]), N[2], p.det.long[2]), + c = matrix(rnorm(p.det.long[3] * N[3]), N[3], p.det.long[3]))) +n.samples <- 1000 +occ.formula <- ~ 1 +det.formula <- list(f.1 = ~ 1, + f.2 = ~ 1, + f.3 = ~ 1) +out <- intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + inits = inits.list, + priors = prior.list, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 400, + n.thin = 3, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class intMsPGOcc", { + expect_s3_class(out, "intMsPGOcc") +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "intMsPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) +}) + +test_that("verbose prints to the screen", { + expect_output(intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + parallel.chains = FALSE, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for intMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check predictions ------------------- +test_that("predict works for intMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, max(N), nrow(dat$X.pred))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, max(N), nrow(dat$X.pred))) +}) + +# Occurrence covariate only ----------------------------------------------- +# Simulate data ----------------------------------------------------------- +# set.seed(883) +J.x <- 10 +J.y <- 10 +# Total number of data sources across the study region +J.all <- J.x * J.y +# Number of data sources. +n.data <- 3 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +n.rep <- list() +# for (i in 1:n.data) { +# n.rep[[i]] <- sample(1:4, size = J.obs[i], replace = TRUE) +# } +n.rep[[1]] <- sample(1, size = J.obs[1], replace = TRUE) +n.rep[[2]] <- sample(2, size = J.obs[2], replace = TRUE) +n.rep[[3]] <- sample(3, size = J.obs[3], replace = TRUE) + +N <- c(7, 4, 5) + +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, -0.3) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.4, 0.5) +# Detection +# Detection covariates +alpha.mean <- list() +tau.sq.alpha <- list() +p.det.long <- c(1, 1, 1) + +for (i in 1:n.data) { + alpha.mean[[i]] <- runif(p.det.long[i], -1, 1) + tau.sq.alpha[[i]] <- runif(p.det.long[i], 0.1, 1) +} +p.det <- sum(p.det.long) + +# Random effects +psi.RE <- list() +# Not currently supported +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = max(N), ncol = p.occ) +for (i in 1:p.occ) { + beta[, i] <- rnorm(max(N), beta.mean[i], sqrt(tau.sq.beta[i])) +} +alpha <- list() +for (i in 1:n.data) { + alpha[[i]] <- matrix(NA, nrow = N[i], ncol = p.det.long[i]) + for (t in 1:p.det.long[i]) { + alpha[[i]][, t] <- rnorm(N[i], alpha.mean[[i]][t], sqrt(tau.sq.alpha[[i]])[t]) + } +} +sp <- FALSE +factor.model <- FALSE + +dat <- simIntMsOcc(n.data = n.data, J.x = J.x, J.y = J.y, + J.obs = J.obs, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = sp, factor.model = factor.model) + +J <- nrow(dat$coords.obs) +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +X.re <- dat$X.re.obs +X.p.re <- dat$X.p.re +sites <- dat$sites +species <- dat$species + +# Package all data into a list +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int', 'occ.cov.1') +#colnames(occ.covs) <- c('occ.cov') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int = X.p[[1]][, , 1]) +det.covs[[2]] <- list(int = X.p[[2]][, , 1]) +det.covs[[3]] <- list(int = X.p[[3]][, , 1]) + +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + species = species) + +prior.list <- list(beta.comm.normal = list(mean = 0, + var = 2.73), + alpha.comm.normal = list(mean = list(0, 0, 0), + var = list(2.73, 2.73, 2.73)), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = list(0.1, 0.1, 0.1), + b = list(0.1, 0.1, 0.1))) +inits.list <- list(alpha.comm = list(0, 0, 0), + beta.comm = 0, + tau.sq.beta = 1, + tau.sq.alpha = list(1, 1, 1), + alpha = list(a = matrix(rnorm(p.det.long[1] * N[1]), N[1], p.det.long[1]), + b = matrix(rnorm(p.det.long[2] * N[2]), N[2], p.det.long[2]), + c = matrix(rnorm(p.det.long[3] * N[3]), N[3], p.det.long[3]))) +n.samples <- 1000 +occ.formula <- ~ occ.cov.1 +det.formula <- list(f.1 = ~ 1, + f.2 = ~ 1, + f.3 = ~ 1) +out <- intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + inits = inits.list, + priors = prior.list, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 400, + n.thin = 3, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class intMsPGOcc", { + expect_s3_class(out, "intMsPGOcc") +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "intMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + parallel.chains = FALSE, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for intMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check predictions ------------------- +test_that("predict works for intMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, max(N), nrow(dat$X.pred))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, max(N), nrow(dat$X.pred))) +}) + +# Detection covariate only ------------------------------------------------ +# Simulate data ----------------------------------------------------------- +# set.seed(883) +J.x <- 10 +J.y <- 10 +# Total number of data sources across the study region +J.all <- J.x * J.y +# Number of data sources. +n.data <- 3 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +n.rep <- list() +n.rep[[1]] <- sample(1, size = J.obs[1], replace = TRUE) +n.rep[[2]] <- sample(2, size = J.obs[2], replace = TRUE) +n.rep[[3]] <- sample(3, size = J.obs[3], replace = TRUE) + +N <- c(7, 4, 5) + +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.4) +# Detection +# Detection covariates +alpha.mean <- list() +tau.sq.alpha <- list() +p.det.long <- c(3, 2, 2) + +for (i in 1:n.data) { + alpha.mean[[i]] <- runif(p.det.long[i], -1, 1) + tau.sq.alpha[[i]] <- runif(p.det.long[i], 0.1, 1) +} +p.det <- sum(p.det.long) + +# Random effects +psi.RE <- list() +# Not currently supported +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = max(N), ncol = p.occ) +for (i in 1:p.occ) { + beta[, i] <- rnorm(max(N), beta.mean[i], sqrt(tau.sq.beta[i])) +} +alpha <- list() +for (i in 1:n.data) { + alpha[[i]] <- matrix(NA, nrow = N[i], ncol = p.det.long[i]) + for (t in 1:p.det.long[i]) { + alpha[[i]][, t] <- rnorm(N[i], alpha.mean[[i]][t], sqrt(tau.sq.alpha[[i]])[t]) + } +} +sp <- FALSE +factor.model <- FALSE + +dat <- simIntMsOcc(n.data = n.data, J.x = J.x, J.y = J.y, + J.obs = J.obs, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = sp, factor.model = factor.model) + +J <- nrow(dat$coords.obs) +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +X.re <- dat$X.re.obs +X.p.re <- dat$X.p.re +sites <- dat$sites +species <- dat$species + +# Package all data into a list +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +#colnames(occ.covs) <- c('occ.cov') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int = X.p[[1]][, , 1], + det.cov.1.1 = X.p[[1]][, , 2], + det.cov.2.1 = X.p[[1]][, , 3]) +det.covs[[2]] <- list(int = X.p[[2]][, , 1], + det.cov.1.2 = X.p[[2]][, , 2]) +det.covs[[3]] <- list(int = X.p[[3]][, , 1], + det.cov.1.3 = X.p[[3]][, , 2]) + +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + species = species) + +prior.list <- list(beta.comm.normal = list(mean = 0, + var = 2.73), + alpha.comm.normal = list(mean = list(0, 0, 0), + var = list(2.73, 2.73, 2.73)), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = list(0.1, 0.1, 0.1), + b = list(0.1, 0.1, 0.1))) +inits.list <- list(alpha.comm = list(0, 0, 0), + beta.comm = 0, + tau.sq.beta = 1, + tau.sq.alpha = list(1, 1, 1), + alpha = list(a = matrix(rnorm(p.det.long[1] * N[1]), N[1], p.det.long[1]), + b = matrix(rnorm(p.det.long[2] * N[2]), N[2], p.det.long[2]), + c = matrix(rnorm(p.det.long[3] * N[3]), N[3], p.det.long[3]))) +n.samples <- 1000 +occ.formula <- ~ 1 +det.formula <- list(f.1 = ~ det.cov.1.1 + det.cov.2.1, + f.2 = ~ det.cov.1.2, + f.3 = ~ det.cov.1.3) +out <- intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + inits = inits.list, + priors = prior.list, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 400, + n.thin = 3, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class intMsPGOcc", { + expect_s3_class(out, "intMsPGOcc") +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "intMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for intMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check predictions ------------------- +test_that("predict works for intMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, max(N), nrow(dat$X.pred))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, max(N), nrow(dat$X.pred))) +}) + +# Covariates on both ------------------------------------------------------ +# Simulate data ----------------------------------------------------------- +# set.seed(883) +J.x <- 10 +J.y <- 10 +# Total number of data sources across the study region +J.all <- J.x * J.y +# Number of data sources. +n.data <- 3 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +n.rep <- list() +n.rep[[1]] <- sample(1, size = J.obs[1], replace = TRUE) +n.rep[[2]] <- sample(2, size = J.obs[2], replace = TRUE) +n.rep[[3]] <- sample(3, size = J.obs[3], replace = TRUE) + +N <- c(7, 4, 5) + +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, -0.3, 0.4) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.4, 0.5, 1.0) +# Detection +# Detection covariates +alpha.mean <- list() +tau.sq.alpha <- list() +p.det.long <- c(3, 2, 2) + +for (i in 1:n.data) { + alpha.mean[[i]] <- runif(p.det.long[i], -1, 1) + tau.sq.alpha[[i]] <- runif(p.det.long[i], 0.1, 1) +} +p.det <- sum(p.det.long) + +# Random effects +psi.RE <- list() +# Not currently supported +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = max(N), ncol = p.occ) +for (i in 1:p.occ) { + beta[, i] <- rnorm(max(N), beta.mean[i], sqrt(tau.sq.beta[i])) +} +alpha <- list() +for (i in 1:n.data) { + alpha[[i]] <- matrix(NA, nrow = N[i], ncol = p.det.long[i]) + for (t in 1:p.det.long[i]) { + alpha[[i]][, t] <- rnorm(N[i], alpha.mean[[i]][t], sqrt(tau.sq.alpha[[i]])[t]) + } +} +sp <- FALSE +factor.model <- FALSE + +dat <- simIntMsOcc(n.data = n.data, J.x = J.x, J.y = J.y, + J.obs = J.obs, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = sp, factor.model = factor.model) + +J <- nrow(dat$coords.obs) +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +X.re <- dat$X.re.obs +X.p.re <- dat$X.p.re +sites <- dat$sites +species <- dat$species + +# Package all data into a list +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int = X.p[[1]][, , 1], + det.cov.1.1 = X.p[[1]][, , 2], + det.cov.2.1 = X.p[[1]][, , 3]) +det.covs[[2]] <- list(int = X.p[[2]][, , 1], + det.cov.1.2 = X.p[[2]][, , 2]) +det.covs[[3]] <- list(int = X.p[[3]][, , 1], + det.cov.1.3 = X.p[[3]][, , 2]) + +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + species = species) + +prior.list <- list(beta.comm.normal = list(mean = 0, + var = 2.73), + alpha.comm.normal = list(mean = list(0, 0, 0), + var = list(2.73, 2.73, 2.73)), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = list(0.1, 0.1, 0.1), + b = list(0.1, 0.1, 0.1))) +inits.list <- list(alpha.comm = list(0, 0, 0), + beta.comm = 0, + tau.sq.beta = 1, + tau.sq.alpha = list(1, 1, 1), + alpha = list(a = matrix(rnorm(p.det.long[1] * N[1]), N[1], p.det.long[1]), + b = matrix(rnorm(p.det.long[2] * N[2]), N[2], p.det.long[2]), + c = matrix(rnorm(p.det.long[3] * N[3]), N[3], p.det.long[3]))) +n.samples <- 1000 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- list(f.1 = ~ det.cov.1.1 + det.cov.2.1, + f.2 = ~ det.cov.1.2, + f.3 = ~ det.cov.1.3) +out <- intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + inits = inits.list, + priors = prior.list, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 400, + n.thin = 3, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class intMsPGOcc", { + expect_s3_class(out, "intMsPGOcc") +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "intMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for intMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check predictions ------------------- +test_that("predict works for intMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, max(N), nrow(dat$X.pred))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, max(N), nrow(dat$X.pred))) +}) + +# Interactions on both ---------------------------------------------------- +# Simulate data ----------------------------------------------------------- +# set.seed(883) +J.x <- 10 +J.y <- 10 +# Total number of data sources across the study region +J.all <- J.x * J.y +# Number of data sources. +n.data <- 3 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +n.rep <- list() +n.rep[[1]] <- sample(1, size = J.obs[1], replace = TRUE) +n.rep[[2]] <- sample(2, size = J.obs[2], replace = TRUE) +n.rep[[3]] <- sample(3, size = J.obs[3], replace = TRUE) + +N <- c(7, 4, 5) + +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, -0.3, 0.4) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.4, 0.5, 1.0) +# Detection +# Detection covariates +alpha.mean <- list() +tau.sq.alpha <- list() +p.det.long <- c(3, 2, 2) + +for (i in 1:n.data) { + alpha.mean[[i]] <- runif(p.det.long[i], -1, 1) + tau.sq.alpha[[i]] <- runif(p.det.long[i], 0.1, 1) +} +p.det <- sum(p.det.long) + +# Random effects +psi.RE <- list() +# Not currently supported +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = max(N), ncol = p.occ) +for (i in 1:p.occ) { + beta[, i] <- rnorm(max(N), beta.mean[i], sqrt(tau.sq.beta[i])) +} +alpha <- list() +for (i in 1:n.data) { + alpha[[i]] <- matrix(NA, nrow = N[i], ncol = p.det.long[i]) + for (t in 1:p.det.long[i]) { + alpha[[i]][, t] <- rnorm(N[i], alpha.mean[[i]][t], sqrt(tau.sq.alpha[[i]])[t]) + } +} +sp <- FALSE +factor.model <- FALSE + +dat <- simIntMsOcc(n.data = n.data, J.x = J.x, J.y = J.y, + J.obs = J.obs, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = sp, factor.model = factor.model) + +J <- nrow(dat$coords.obs) +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +X.re <- dat$X.re.obs +X.p.re <- dat$X.p.re +sites <- dat$sites +species <- dat$species + +# Package all data into a list +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int = X.p[[1]][, , 1], + det.cov.1.1 = X.p[[1]][, , 2], + det.cov.2.1 = X.p[[1]][, , 3]) +det.covs[[2]] <- list(int = X.p[[2]][, , 1], + det.cov.1.2 = X.p[[2]][, , 2]) +det.covs[[3]] <- list(int = X.p[[3]][, , 1], + det.cov.1.3 = X.p[[3]][, , 2]) + +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + species = species) + +prior.list <- list(beta.comm.normal = list(mean = 0, + var = 2.73), + alpha.comm.normal = list(mean = list(0, 0, 0), + var = list(2.73, 2.73, 2.73)), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = list(0.1, 0.1, 0.1), + b = list(0.1, 0.1, 0.1))) +inits.list <- list(alpha.comm = list(0, 0, 0), + beta.comm = 0, + tau.sq.beta = 1, + tau.sq.alpha = list(1, 1, 1), + alpha = list(a = 0, + b = matrix(rnorm(p.det.long[2] * N[2]), N[2], p.det.long[2]), + c = matrix(rnorm(p.det.long[3] * N[3]), N[3], p.det.long[3]))) +n.samples <- 1000 +occ.formula <- ~ occ.cov.1 * occ.cov.2 +det.formula <- list(f.1 = ~ det.cov.1.1 * det.cov.2.1, + f.2 = ~ det.cov.1.2, + f.3 = ~ det.cov.1.3) +out <- intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + inits = inits.list, + priors = prior.list, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 400, + n.thin = 3, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class intMsPGOcc", { + expect_s3_class(out, "intMsPGOcc") +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "intMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(intMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for intMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check predictions ------------------- +test_that("predict works for intMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(dat$X.pred, dat$X.pred[, 3] * dat$X.pred[, 2]) + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, max(N), nrow(dat$X.pred))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, max(N), nrow(dat$X.pred))) +}) diff --git a/tests/testthat/test-intPGOcc.R b/tests/testthat/test-intPGOcc.R new file mode 100644 index 0000000..aea1cde --- /dev/null +++ b/tests/testthat/test-intPGOcc.R @@ -0,0 +1,1334 @@ +# Test intPGOcc.R ---------------------------------------------------------- + +skip_on_cran() + +# Intercept only ---------------------------------------------------------- +set.seed(111) +J.x <- 15 +J.y <- 15 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(1:4, size = J.obs[i], replace = TRUE) +} +# Occupancy covariates +beta <- c(0.5) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +for (i in 1:n.data) { + alpha[[i]] <- runif(1, -1, 1) +} +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) + +# Simulate occupancy data. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = FALSE) + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int') +det.covs <- list() +data.list <- list(y = y, + occ.covs = occ.covs, + sites = sites) + +J <- length(dat$z.obs) +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + fix = TRUE, + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72))) +n.samples <- 1000 +occ.formula <- ~ 1 +det.formula <- list(f.1 = ~ 1, f.2 = ~ 1, f.3 = ~ 1, f.4 = ~ 1) +out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class intPGOcc", { + expect_s3_class(out, "intPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin, work", { + + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = FALSE, + n.chains = 1) + expect_s3_class(out, "intPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) +}) + +test_that("verbose prints to the screen", { + + expect_output(out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = 100, + priors = prior.list, + n.omp.threads = 1, + verbose = TRUE, + n.report = 25, + n.burn = 1, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for intPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for intPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for intPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for intPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + +# Occurrence covariate only ----------------------------------------------- +J.x <- 15 +J.y <- 15 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(1:4, size = J.obs[i], replace = TRUE) +} +# Occupancy covariates +beta <- c(0.5, 1.2, -0.8) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +for (i in 1:n.data) { + alpha[[i]] <- runif(1, -1, 1) +} +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) + +# Simulate occupancy data. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = FALSE) + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list() +data.list <- list(y = y, + occ.covs = occ.covs, + sites = sites) + +J <- length(dat$z.obs) +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72))) +n.samples <- 1000 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- list(f.1 = ~ 1, f.2 = ~ 1, f.3 = ~ 1, f.4 = ~ 1) +out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class intPGOcc", { + expect_s3_class(out, "intPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 500, + n.thin = 2, + n.chains = 1, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(PGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE)) + # tmp.data <- data.list + # tmp.data$y[1, 1] <- NA + # out <- PGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE) + # expect_s3_class(out, "PGOcc") +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin, work", { + + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = FALSE, + n.chains = 1) + expect_s3_class(out, "intPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = 100, + priors = prior.list, + n.omp.threads = 1, + verbose = TRUE, + n.report = 25, + n.burn = 1, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for intPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for intPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for intPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for intPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + +# Detection covariate only ----------------------------------------------- +J.x <- 15 +J.y <- 15 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(2:4, size = J.obs[i], replace = TRUE) +} +# Occupancy covariates +beta <- c(0.5) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +for (i in 1:n.data) { + alpha[[i]] <- runif(2, -1, 1) +} +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) + +# Simulate occupancy data. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = FALSE) + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(det.cov.1.1 = X.p[[1]][, , 2]) +det.covs[[2]] <- list(det.cov.2.1 = X.p[[2]][, , 2]) +det.covs[[3]] <- list(det.cov.3.1 = X.p[[3]][, , 2]) +det.covs[[4]] <- list(det.cov.4.1 = X.p[[4]][, , 2]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites) + +J <- length(dat$z.obs) +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72))) +n.samples <- 1000 +occ.formula <- ~ 1 +det.formula <- list(f.1 = ~ det.cov.1.1, + f.2 = ~ det.cov.2.1, + f.3 = ~ det.cov.3.1, + f.4 = ~ det.cov.4.1) +out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 500, + n.thin = 2, + n.chains = 1, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class intPGOcc", { + expect_s3_class(out, "intPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(intPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- 1 + tmp.data$det.covs[[1]][[1]][1] <- NA + expect_error(intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- NA + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "intPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin, work", { + + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = FALSE, + n.chains = 1) + expect_s3_class(out, "intPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = 100, + priors = prior.list, + n.omp.threads = 1, + verbose = TRUE, + n.report = 25, + n.burn = 1, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for intPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for intPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for intPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for intPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + +# Covariates on both ------------------------------------------------------ +J.x <- 15 +J.y <- 15 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(2:4, size = J.obs[i], replace = TRUE) +} +# Occupancy covariates +beta <- c(0.5, 1.2, -0.8) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +alpha[[1]] <- c(1, -0.5) +alpha[[2]] <- c(0, -0.2, 0.5) +alpha[[3]] <- c(0.25) +alpha[[4]] <- c(-1, 1, 0.3) +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) + +# Simulate occupancy data. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = FALSE) + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(det.cov.1.1 = X.p[[1]][, , 2]) +det.covs[[2]] <- list(det.cov.2.1 = X.p[[2]][, , 2], + det.cov.2.2 = X.p[[2]][, , 3]) +det.covs[[3]] <- list(int = X.p[[3]][, , 1]) +det.covs[[4]] <- list(det.cov.4.1 = X.p[[4]][, , 2], + det.cov.4.2 = X.p[[4]][, , 3]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites) + +J <- length(dat$z.obs) +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72))) +n.samples <- 1000 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- list(f.1 = ~ det.cov.1.1, + f.2 = ~ det.cov.2.1 + det.cov.2.2, + f.3 = ~ 1, + f.4 = ~ det.cov.4.1 + det.cov.4.2) +out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class intPGOcc", { + expect_s3_class(out, "intPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- 1 + tmp.data$det.covs[[1]][[1]][1] <- NA + expect_error(intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- NA + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "intPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin, work", { + + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = FALSE, + n.chains = 1) + expect_s3_class(out, "intPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = 100, + priors = prior.list, + n.omp.threads = 1, + verbose = TRUE, + n.report = 25, + n.burn = 1, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for intPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for intPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for intPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for intPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + +# Interactions on both ---------------------------------------------------- +J.x <- 15 +J.y <- 15 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(2:4, size = J.obs[i], replace = TRUE) +} +# Occupancy covariates +beta <- c(0.5, 1.2, -0.8) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +alpha[[1]] <- c(1, -0.5) +alpha[[2]] <- c(0, -0.2, 0.5) +alpha[[3]] <- c(0.25) +alpha[[4]] <- c(-1, 1, 0.3) +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) + +# Simulate occupancy data. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = FALSE) + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(det.cov.1.1 = X.p[[1]][, , 2]) +det.covs[[2]] <- list(det.cov.2.1 = X.p[[2]][, , 2], + det.cov.2.2 = X.p[[2]][, , 3]) +det.covs[[3]] <- list(int = X.p[[3]][, , 1]) +det.covs[[4]] <- list(det.cov.4.1 = X.p[[4]][, , 2], + det.cov.4.2 = X.p[[4]][, , 3]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites) + +J <- length(dat$z.obs) +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72))) +n.samples <- 1000 +occ.formula <- ~ occ.cov.1 * occ.cov.2 +det.formula <- list(f.1 = ~ det.cov.1.1, + f.2 = ~ det.cov.2.1 * det.cov.2.2, + f.3 = ~ 1, + f.4 = ~ det.cov.4.1 + det.cov.4.2) +out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class intPGOcc", { + expect_s3_class(out, "intPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- 1 + tmp.data$det.covs[[1]][[1]][1] <- NA + expect_error(intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- NA + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "intPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin, work", { + + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = FALSE, + n.chains = 1) + expect_s3_class(out, "intPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = 100, + priors = prior.list, + n.omp.threads = 1, + verbose = TRUE, + n.report = 25, + n.burn = 1, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for intPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for intPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for intPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + X.0 <- cbind(X.0, X.0[, 2] * X.0[, 3]) + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for intPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + +# Covariates on both ------------------------------------------------------ +J.x <- 15 +J.y <- 15 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(2:4, size = J.obs[i], replace = TRUE) +} +n.rep.max <- c(6, 4, 4, 5) +# Occupancy covariates +beta <- c(0.5, 1.2, -0.8) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +alpha[[1]] <- c(1, -0.5) +alpha[[2]] <- c(0, -0.2, 0.5) +alpha[[3]] <- c(0.25) +alpha[[4]] <- c(-1, 1, 0.3) +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) + +# Simulate occupancy data. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = FALSE, n.rep.max = n.rep.max) + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(det.cov.1.1 = X.p[[1]][, , 2]) +det.covs[[2]] <- list(det.cov.2.1 = X.p[[2]][, , 2], + det.cov.2.2 = X.p[[2]][, , 3]) +det.covs[[3]] <- list(int = X.p[[3]][, , 1]) +det.covs[[4]] <- list(det.cov.4.1 = X.p[[4]][, , 2], + det.cov.4.2 = X.p[[4]][, , 3]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites) + +J <- length(dat$z.obs) +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72))) +n.samples <- 1000 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- list(f.1 = ~ det.cov.1.1, + f.2 = ~ det.cov.2.1 + det.cov.2.2, + f.3 = ~ 1, + f.4 = ~ det.cov.4.1 + det.cov.4.2) +out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class intPGOcc", { + expect_s3_class(out, "intPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = 100, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- 1 + tmp.data$det.covs[[1]][[1]][1] <- NA + expect_error(intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- NA + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "intPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin, work", { + + out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = FALSE, + n.chains = 1) + expect_s3_class(out, "intPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(out <- intPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = 100, + priors = prior.list, + n.omp.threads = 1, + verbose = TRUE, + n.report = 25, + n.burn = 1, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for intPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for intPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for intPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for intPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + diff --git a/tests/testthat/test-lfJSDM.R b/tests/testthat/test-lfJSDM.R new file mode 100644 index 0000000..bd5aeab --- /dev/null +++ b/tests/testthat/test-lfJSDM.R @@ -0,0 +1,868 @@ +# Test lfJSDM.R ------------------------------------------------------- + +skip_on_cran() + +# Intercept only ---------------------------------------------------------- +set.seed(1818) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE, factor.model = TRUE, n.factors = 3) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +y <- apply(y, c(1, 2), max, na.rm = TRUE) +data.list <- list(y = y, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(beta.comm = 0, + beta = 0, + fix = TRUE, + tau.sq.beta = 1) + +n.samples <- 1000 +n.report <- 100 +formula <- ~ 1 + +out <- lfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfJSDM", { + expect_s3_class(out, "lfJSDM") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + out.k.fold <- lfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1, k.fold.only = TRUE) + expect_equal(length(out.k.fold$k.fold.deviance), N) + expect_type(out.k.fold$k.fold.deviance, "double") + expect_equal(sum(out.k.fold$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfJSDM(formula = formula, + data = data.list, + n.factors = 3, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfJSDM") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- lfJSDM(formula = ~ 1, + data = data.list, + n.thin = 13, + n.factors = 3, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) +}) + +test_that("verbose prints to the screen", { + expect_output(lfJSDM(formula = formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + n.factors = 3, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfJSDM", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfJSDM", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$z.samples), "array") + expect_equal(class(fitted.out$psi.samples), "array") + expect_equal(dim(fitted.out$z.samples), dim(fitted.out$psi.samples)) +}) + +test_that("predict works for lfJSDM", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) + +test_that("posterior predictive checks work for lfJSDM", { + expect_error(ppcOcc(out, 'chi-square', 2)) +}) + +# Covariates -------------------------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.2, -0.4) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.3, 2.5) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE, factor.model = TRUE, n.factors = 3) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +y <- apply(y, c(1, 2), max, na.rm = TRUE) +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +data.list <- list(y = y, coords = coords, covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(beta.comm = 0, + beta = 0, + tau.sq.beta = 1) + +n.samples <- 1000 +n.report <- 100 +formula <- ~ occ.cov.1 + occ.cov.2 + +out <- lfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfJSDM", { + expect_s3_class(out, "lfJSDM") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfJSDM(formula = formula, + data = data.list, + n.factors = 3, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfJSDM") +}) + +test_that("verbose prints to the screen", { + expect_output(lfJSDM(formula = formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + n.factors = 3, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfJSDM", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfJSDM", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$z.samples), "array") + expect_equal(class(fitted.out$psi.samples), "array") + expect_equal(dim(fitted.out$z.samples), dim(fitted.out$psi.samples)) +}) + +test_that("predict works for lfJSDM", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) + +test_that("posterior predictive checks work for lfJSDM", { + expect_error(ppcOcc(out, 'chi-square', 2)) +}) + +# Random intercept -------------------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(0.5)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE, factor.model = TRUE, n.factors = 3) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +y <- apply(y, c(1, 2), max, na.rm = TRUE) +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +data.list <- list(y = y, coords = coords, covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(beta.comm = 0, + beta = 0, + tau.sq.beta = 1) + +n.samples <- 1000 +n.report <- 100 +formula <- ~ (1 | occ.factor.1) + +out <- lfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfJSDM", { + expect_s3_class(out, "lfJSDM") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$covs <- as.data.frame(data.list$covs) + data.list$covs$occ.factor.1 <- factor(data.list$covs$occ.factor.1) + expect_error(out <- lfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$covs$occ.factor.1 <- as.character(factor(data.list$covs$occ.factor.1)) + expect_error(out <- lfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfJSDM(formula = formula, + data = data.list, + n.factors = 3, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfJSDM") +}) + +test_that("verbose prints to the screen", { + expect_output(lfJSDM(formula = formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + n.factors = 3, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfJSDM", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfJSDM", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$z.samples), "array") + expect_equal(class(fitted.out$psi.samples), "array") + expect_equal(dim(fitted.out$z.samples), dim(fitted.out$psi.samples)) +}) + +test_that("predict works for lfJSDM", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) + +test_that("posterior predictive checks work for lfJSDM", { + expect_error(ppcOcc(out, 'chi-square', 2)) +}) + +# Multiple random intercepts ---------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20, 30), + sigma.sq.psi = c(0.5, 1.5)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE, factor.model = TRUE, n.factors = 3) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +y <- apply(y, c(1, 2), max, na.rm = TRUE) +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(beta.comm = 0, + beta = 0, + tau.sq.beta = 1) + +n.samples <- 1000 +n.report <- 100 +formula <- ~ (1 | occ.factor.1) + (1 | occ.factor.2) + +out <- lfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfJSDM", { + expect_s3_class(out, "lfJSDM") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$covs <- as.data.frame(data.list$covs) + data.list$covs$occ.factor.1 <- factor(data.list$covs$occ.factor.1) + expect_error(out <- lfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$covs$occ.factor.1 <- as.character(factor(data.list$covs$occ.factor.1)) + expect_error(out <- lfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfJSDM(formula = formula, + data = data.list, + n.factors = 3, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfJSDM") +}) + +test_that("verbose prints to the screen", { + expect_output(lfJSDM(formula = formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + n.factors = 3, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfJSDM", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfJSDM", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$z.samples), "array") + expect_equal(class(fitted.out$psi.samples), "array") + expect_equal(dim(fitted.out$z.samples), dim(fitted.out$psi.samples)) +}) + +test_that("predict works for lfJSDM", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) + +test_that("posterior predictive checks work for lfJSDM", { + expect_error(ppcOcc(out, 'chi-square', 2)) +}) + +# Random intercepts + covariates ------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, -1) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.3) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20, 30), + sigma.sq.psi = c(0.5, 1.5)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE, factor.model = TRUE, n.factors = 3) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +y <- apply(y, c(1, 2), max, na.rm = TRUE) +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(beta.comm = 0, + beta = 0, + tau.sq.beta = 1) + +n.samples <- 1000 +n.report <- 100 +formula <- ~ occ.cov.1 + (1 | occ.factor.1) + (1 | occ.factor.2) + +out <- lfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 1, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfJSDM", { + expect_s3_class(out, "lfJSDM") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$covs <- as.data.frame(data.list$covs) + data.list$covs$occ.factor.1 <- factor(data.list$covs$occ.factor.1) + expect_error(out <- lfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$covs$occ.factor.1 <- as.character(factor(data.list$covs$occ.factor.1)) + expect_error(out <- lfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfJSDM(formula = formula, + data = data.list, + n.factors = 3, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfJSDM") +}) + +test_that("verbose prints to the screen", { + expect_output(lfJSDM(formula = formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + n.factors = 3, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfJSDM", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfJSDM", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$z.samples), "array") + expect_equal(class(fitted.out$psi.samples), "array") + expect_equal(dim(fitted.out$z.samples), dim(fitted.out$psi.samples)) +}) + +test_that("predict works for lfJSDM", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) + +test_that("posterior predictive checks work for lfJSDM", { + expect_error(ppcOcc(out, 'chi-square', 2)) +}) + diff --git a/tests/testthat/test-lfMsPGOcc.R b/tests/testthat/test-lfMsPGOcc.R new file mode 100644 index 0000000..c66daa5 --- /dev/null +++ b/tests/testthat/test-lfMsPGOcc.R @@ -0,0 +1,3785 @@ +# Test lfMsPGOcc.R ------------------------------------------------------- + +skip_on_cran() + +# Intercept only ---------------------------------------------------------- +set.seed(20) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE, factor.model = TRUE, n.factors = 3) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +data.list <- list(y = y, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + fix = TRUE, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ 1 + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + out.k.fold <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1, k.fold.only = TRUE) + expect_equal(length(out.k.fold$k.fold.deviance), N) + expect_type(out.k.fold$k.fold.deviance, "double") + expect_equal(sum(out.k.fold$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.factors = 3, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.factors = 3, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + n.factors = 3, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + + +# Occurrence covariate only ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 0.3) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.3, 2.8) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE, factor.model = TRUE, n.factor = 3) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +data.list <- list(y = y, occ.covs = occ.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ 1 + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Detection covariate only ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, 0.5, 1.2) +tau.sq.alpha <- c(1, 2, 3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Covariates on both ------------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.3) +# Detection +alpha.mean <- c(0, 0.5, 1.2) +tau.sq.alpha <- c(1, 2, 3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + colnames(X.0) <- c('int', 'occ.cov.1') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + J.fit <- nrow(X) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Interactions on both ---------------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.5, -0.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.3, 1.2) +# Detection +alpha.mean <- c(0, 0.5, 1.2) +tau.sq.alpha <- c(1, 2, 3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 * occ.cov.2 +det.formula <- ~ det.cov.1 * det.cov.2 + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X + X.0 <- cbind(X.0, X.0[, 2] * X.0[, 3]) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.cov.1:occ.cov.2') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + X.p.0 <- cbind(X.p.0, X.p.0[, 2] * X.p.0[, 3]) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + J.fit <- nrow(X) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Site covariate on detection --------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.3) +# Detection +alpha.mean <- c(0, 0.5, 1.2) +tau.sq.alpha <- c(1, 2, 3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3], + occ.cov.1 = X[, 2]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 +det.formula <- ~ occ.cov.1 + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 1, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + colnames(X.0) <- c('int', 'occ.cov.1') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(1, data.list$det.covs$occ.cov.1) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(X.p.0))) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + J.fit <- nrow(X) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercept on occurrence ------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45), + sigma.sq.psi = c(1.3)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +# det.covs <- list(det.cov.1 = X.p[, , 2], +# det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ 1 + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X, X.re) + colnames(X.0) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + J.fit <- nrow(X) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts on occurrence -------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45, 15), + sigma.sq.psi = c(1.3, 0.5)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1', 'occ.factor.2') +# det.covs <- list(det.cov.1 = X.p[, , 2], +# det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + J.fit <- nrow(X) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence REs + covariates --------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45, 15), + sigma.sq.psi = c(1.3, 0.5)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') +# det.covs <- list(det.cov.1 = X.p[, , 2], +# det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.str <- cbind(X.0, X.re.0) + colnames(X.str) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.str, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + J.fit <- nrow(X) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence REs + covariates in all -------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2) +# Detection +alpha.mean <- c(0, 1) +tau.sq.alpha <- c(1, 2.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45, 15), + sigma.sq.psi = c(1.3, 0.5)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ det.cov.1 + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + J.fit <- nrow(X) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercepts on detection ------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, 1) +tau.sq.alpha <- c(1, 2.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(30), + sigma.sq.p = c(2)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, 1], dat$X.p.re[, 1, 1]) + colnames(X.p.0) <- c('intercept', 'det.factor.1') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + J.fit <- nrow(X) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts on detection --------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, 1) +tau.sq.alpha <- c(1, 2.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(30, 45), + sigma.sq.p = c(2, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, 1], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + J.fit <- nrow(X) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts with covariate ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, 1) +tau.sq.alpha <- c(1, 2.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(30, 45), + sigma.sq.p = c(2, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + J.fit <- nrow(X) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts with covariate on both ----------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5) +# Detection +alpha.mean <- c(0, 1) +tau.sq.alpha <- c(1, 2.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(30, 45), + sigma.sq.p = c(2, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int', 'occ.cov.1') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + J.fit <- nrow(X) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts on both -------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(0.5)) +p.RE <- list(levels = c(30, 45), + sigma.sq.p = c(2, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + J.fit <- nrow(X) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercepts on both with covariates ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.2) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 1.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20, 15), + sigma.sq.psi = c(0.5, 2.4)) +p.RE <- list(levels = c(30, 45, 30), + sigma.sq.p = c(2, 1.5, 0.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.cov.1 = X.p[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + det.cov.1 + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2', + 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + J.fit <- nrow(X) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Third dimension of y != max(n.rep) -------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +n.rep.max <- max(n.rep) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.3) +# Detection +alpha.mean <- c(0, 0.5, 1.2) +tau.sq.alpha <- c(1, 2, 3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE, n.rep.max = n.rep.max) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + n.factors = 3, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class lfMsPGOcc", { + expect_s3_class(out, "lfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "lfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(lfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for lfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for lfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + colnames(X.0) <- c('int', 'occ.cov.1') + pred.out <- predict(out, X.0, coords.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for lfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + J.fit <- nrow(X) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.rep.max)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.rep.max)) +}) + diff --git a/tests/testthat/test-msPGOcc.R b/tests/testthat/test-msPGOcc.R new file mode 100644 index 0000000..57be6ae --- /dev/null +++ b/tests/testthat/test-msPGOcc.R @@ -0,0 +1,4228 @@ +# Test msPGOcc.R -------------------------------------------------------- + +skip_on_cran() + +# Intercept only ---------------------------------------------------------- +set.seed(123) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +X.p <- dat$X.p + +data.list <- list(y = y) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + fix = TRUE, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ 1 + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +# Check predictions ------------------- +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence covariate only ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 0.3) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.3, 2.8) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +X.p <- dat$X.p + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +data.list <- list(y = y, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ 1 + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 1, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(msPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE)) + # tmp.data <- data.list + # tmp.data$y[, 1, 1] <- NA + # out <- msPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE) + # expect_s3_class(out, "msPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2') + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Detection covariate only ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, 0.5, 1.2) +tau.sq.alpha <- c(1, 2, 3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +X.p <- dat$X.p + +occ.covs <- X +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(msPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Covariates on both ------------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.3) +# Detection +alpha.mean <- c(0, 0.5, 1.2) +tau.sq.alpha <- c(1, 2, 3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +X.p <- dat$X.p + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 1, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X + colnames(X.0) <- c('int', 'occ.cov.1') + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Interactions on both ---------------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.5, 0.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.3, 2.2) +# Detection +alpha.mean <- c(0, 0.5, 1.2) +tau.sq.alpha <- c(1, 2, 3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +X.p <- dat$X.p + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 * occ.cov.2 +det.formula <- ~ det.cov.1 * det.cov.2 + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X + X.0 <- cbind(X.0, X.0[, 2] * X.0[, 3]) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.cov.1:occ.cov.2') + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + X.p.0 <- cbind(X.p.0, X.p.0[, 2] * X.p.0[, 3]) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Site covariate on detection --------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.3) +# Detection +alpha.mean <- c(0, 0.5, 1.2) +tau.sq.alpha <- c(1, 2, 3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +X.p <- dat$X.p + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3], + occ.cov.1 = X[, 2]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 +det.formula <- ~ occ.cov.1 + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(msPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[3]][1] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X + colnames(X.0) <- c('int', 'occ.cov.1') + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(1, data.list$det.covs$occ.cov.1) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercept on occurrence ------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45), + sigma.sq.psi = c(1.3)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re + 10 +X.p <- dat$X.p + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +# det.covs <- list(det.cov.1 = X.p[, , 2], +# det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ 1 + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(msPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE)) + # tmp.data <- data.list + # tmp.data$y[, 1, 1] <- NA + # out <- msPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE) + # expect_s3_class(out, "msPGOcc") +}) + + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, occ.covs) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts on occurrence -------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45, 15), + sigma.sq.psi = c(1.3, 0.5)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re + 10 +X.p <- dat$X.p + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1', 'occ.factor.2') +# det.covs <- list(det.cov.1 = X.p[, , 2], +# det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(msPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE)) + # tmp.data <- data.list + # tmp.data$y[, 1, 1] <- NA + # out <- msPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE) + # expect_s3_class(out, "msPGOcc") +}) + + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, occ.covs) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence REs + covariates --------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45, 15), + sigma.sq.psi = c(1.3, 0.5)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re + 10 +X.p <- dat$X.p + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') +# det.covs <- list(det.cov.1 = X.p[, , 2], +# det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(msPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE)) + # tmp.data <- data.list + # tmp.data$y[, 1, 1] <- NA + # out <- msPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE) + # expect_s3_class(out, "msPGOcc") +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, occ.covs) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence REs + covariates in all -------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2) +# Detection +alpha.mean <- c(0, 1) +tau.sq.alpha <- c(1, 2.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45, 15), + sigma.sq.psi = c(1.3, 0.5)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re + 10 +X.p <- dat$X.p + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ det.cov.1 + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, occ.covs) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercepts on detection ------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, 1) +tau.sq.alpha <- c(1, 2.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(30), + sigma.sq.p = c(2)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +# X.re <- dat$X.re + 10 +X.p <- dat$X.p +X.p.re <- dat$X.p.re + 20 + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(msPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, occ.covs) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, 1], dat$X.p.re[, 1, 1]) + colnames(X.p.0) <- c('intercept', 'det.factor.1') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts on detection --------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, 1) +tau.sq.alpha <- c(1, 2.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(30, 45), + sigma.sq.p = c(2, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +# X.re <- dat$X.re + 10 +X.p <- dat$X.p +X.p.re <- dat$X.p.re + 20 + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(msPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, occ.covs) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, 1], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts with covariate ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, 1) +tau.sq.alpha <- c(1, 2.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(30, 45), + sigma.sq.p = c(2, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +# X.re <- dat$X.re + 10 +X.p <- dat$X.p +X.p.re <- dat$X.p.re + 20 + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(msPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.samples = n.samples, + # n.omp.threads = 1, + # verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, occ.covs) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts with covariate on both ----------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5) +# Detection +alpha.mean <- c(0, 1) +tau.sq.alpha <- c(1, 2.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(30, 45), + sigma.sq.p = c(2, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +# X.re <- dat$X.re + 10 +X.p <- dat$X.p +X.p.re <- dat$X.p.re + 20 + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, occ.covs) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts with covariate on both ----------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(0.5)) +p.RE <- list(levels = c(30, 45), + sigma.sq.p = c(2, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re + 10 +X.p <- dat$X.p +X.p.re <- dat$X.p.re + 20 + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, occ.covs) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercepts on both with covariates ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.2) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 1.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20, 15), + sigma.sq.psi = c(0.5, 2.4)) +p.RE <- list(levels = c(30, 45, 30), + sigma.sq.p = c(2, 1.5, 0.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re + 10 +X.p <- dat$X.p +X.p.re <- dat$X.p.re + 20 + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.cov.1 = X.p[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + det.cov.1 + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, occ.covs) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2', + 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Third dimension of y != max(n.rep) -------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +n.rep.max <- 7 +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.3) +# Detection +alpha.mean <- c(0, 0.5, 1.2) +tau.sq.alpha <- c(1, 2, 3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE, n.rep.max = n.rep.max) +y <- dat$y +X <- dat$X +X.p <- dat$X.p + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) + +n.samples <- 1000 +n.report <- 100 +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X + colnames(X.0) <- c('int', 'occ.cov.1') + pred.out <- predict(out, X.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.rep.max)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.rep.max)) +}) + +# Random site-level intercept on detection -------------------------------- +J.x <- 6 +J.y <- 6 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +# n.rep <- rep(3, J) +N <- 8 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(5), + sigma.sq.psi = c(0.3)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = FALSE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re + 10 +X.p <- dat$X.p + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.re[, 1]) +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + +out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 3, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class msPGOcc", { + expect_s3_class(out, "msPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check cross-validation -------------- +test_that("cross-validation only works", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.samples = n.samples, + priors = prior.list, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 3, + k.fold.threads = 1, k.fold.only = TRUE) + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = n.samples, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "msPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(msPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.samples = 100, + n.omp.threads = 1, + verbose = TRUE, + n.report = 100, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for msPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for msPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, occ.covs) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, J)) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, J)) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.re[, 1]) + colnames(X.p.0) <- c('(Intercept)', 'det.factor.1') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) diff --git a/tests/testthat/test-postHocLM.R b/tests/testthat/test-postHocLM.R new file mode 100644 index 0000000..12b9b65 --- /dev/null +++ b/tests/testthat/test-postHocLM.R @@ -0,0 +1,173 @@ +# Test postHocLM.R -------------------------------------------------------- + +skip_on_cran() + + +# Fixed effects only ------------------------------------------------------ +set.seed(100) +N <- 100 +beta <- c(0, 0.5, 1.2) +tau.sq <- 2 +p <- length(beta) +X <- matrix(1, nrow = N, ncol = p) +if (p > 1) { + for (i in 2:p) { + X[, i] <- rnorm(N) + } # i +} +mu <- X %*% as.matrix(beta) +y <- rnorm(N, mu, sqrt(tau.sq)) +y.small <- y +# Replicate y n.samples times +n.samples <- 1000 +y <- matrix(y, n.samples, N, byrow = TRUE) +y <- y + rnorm(length(y), 0, 0.5) + +covs <- cbind(X) +colnames(covs) <- c('int', 'cov.1', 'cov.2') +data.list <- list(y = y, + covs = covs) +inits <- list(beta = 0, tau.sq = 1, sigma.sq = 1) +priors <- list(beta.normal = list(mean = 0, var = 10000), + tau.sq.ig = c(0.001, 0.001), + sigma.sq.ig = list(a = 0.1, b = 0.1)) +out <- postHocLM(formula = ~ cov.1 + cov.2, + inits = inits, + data = data.list, + priors = priors, + verbose = FALSE, + n.samples = 1000, + n.chains = 1) + +# Test to make sure it worked --------- +test_that("out is of class postHocLM", { + expect_s3_class(out, "postHocLM") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$RE, FALSE) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- postHocLM(formula = ~ cov.1 + cov.2, + data = data.list, + verbose = FALSE, + n.samples = 10000, + n.chains = 1) + expect_s3_class(out, "postHocLM") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { +expect_output(postHocLM(formula = ~ cov.1 + cov.2, + inits = inits, + data = data.list, + priors = priors, + verbose = TRUE, + n.samples = 1000, + n.chains = 1)) +}) + +# Fixed and random effects ------------------------------------------------ +set.seed(100) +N <- 100 +beta <- c(0, 0.5, 1.2) +tau.sq <- 2 +RE <- list(levels = c(20, 10), + sigma.sq = c(2, 0.5)) +p <- length(beta) +X <- matrix(1, nrow = N, ncol = p) +if (p > 1) { + for (i in 2:p) { + X[, i] <- rnorm(N) + } # i +} +if (length(RE) > 0) { + p.re <- length(RE$levels) + sigma.sq <- rep(NA, p.re) + n.re.long <- RE$levels + n.re <- sum(n.re.long) + beta.star.indx <- rep(1:p.re, n.re.long) + beta.star <- rep(0, n.re) + X.re <- matrix(NA, N, p.re) + for (i in 1:p.re) { + X.re[, i] <- sample(1:RE$levels[i], N, replace = TRUE) + beta.star[which(beta.star.indx == i)] <- rnorm(RE$levels[i], 0, sqrt(RE$sigma.sq[i])) + } + if (p.re > 1) { + for (j in 2:p.re) { + X.re[, j] <- X.re[, j] + max(X.re[, j - 1], na.rm = TRUE) + } + } + beta.star.sites <- apply(X.re, 1, function(a) sum(beta.star[a])) +} else { + X.re <- NA + beta.star <- NA + beta.star.sites <- rep(0, N) +} +mu <- X %*% as.matrix(beta) + beta.star.sites +y <- rnorm(N, mu, sqrt(tau.sq)) +y.small <- y +# Replicate y n.samples times +n.samples <- 1000 +y <- matrix(y, n.samples, N, byrow = TRUE) +y <- y + rnorm(length(y), 0, 0.5) + +covs <- cbind(X, X.re) +colnames(covs) <- c('int', 'cov.1', 'cov.2', 'factor.1', 'factor.2') +data.list <- list(y = y, + covs = covs) +inits <- list(beta = 0, tau.sq = 1, sigma.sq = 1) +priors <- list(beta.normal = list(mean = 0, var = 10000), + tau.sq.ig = c(0.001, 0.001), + sigma.sq.ig = list(a = 0.1, b = 0.1)) +out <- postHocLM(formula = ~ cov.1 + cov.2 + (1 | factor.1) + (1 | factor.2), + inits = inits, + data = data.list, + priors = priors, + verbose = FALSE, + n.samples = 10000, + n.chains = 1) + +# Test to make sure it worked --------- +test_that("out is of class postHocLM", { + expect_s3_class(out, "postHocLM") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$RE, TRUE) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- postHocLM(formula = ~ cov.1 + cov.2 + (1 | factor.1) + (1 | factor.2), + data = data.list, + verbose = FALSE, + n.samples = 10000, + n.chains = 1) + expect_s3_class(out, "postHocLM") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { +expect_output(postHocLM(formula = ~ cov.1 + cov.2 + (1 | factor.1) + (1 | factor.2), + inits = inits, + data = data.list, + priors = priors, + verbose = TRUE, + n.samples = 1000, + n.chains = 1)) +}) diff --git a/tests/testthat/test-sfJSDM-NNGP.R b/tests/testthat/test-sfJSDM-NNGP.R new file mode 100644 index 0000000..cce4dfd --- /dev/null +++ b/tests/testthat/test-sfJSDM-NNGP.R @@ -0,0 +1,1446 @@ +# Test sfJSDM.R ------------------------------------------------------- +# NNGP -------------------------------------------------------------------- + +skip_on_cran() + +# Intercept Only ---------------------------------------------------------- +set.seed(833) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', factor.model = TRUE, + n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +y <- apply(y, c(1, 2), max, na.rm = TRUE) +data.list <- list(y = y, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(beta.comm = 0, + beta = 0, + fix = TRUE, + tau.sq.beta = 1) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 40 +n.report <- 100 +formula <- ~ 1 + +out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfJSDM", { + expect_s3_class(out, "sfJSDM") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + out.k.fold <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.only = TRUE, + k.fold.threads = 1) + + expect_equal(length(out.k.fold$k.fold.deviance), N) + expect_type(out.k.fold$k.fold.deviance, "double") + expect_equal(sum(out.k.fold$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfJSDM(formula = formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfJSDM") +}) + +test_that("all correlation functions work", { + out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfJSDM") + + out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfJSDM") + + out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfJSDM") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfJSDM", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfJSDM", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$z.samples), "array") + expect_equal(class(fitted.out$psi.samples), "array") + expect_equal(dim(fitted.out$z.samples), dim(fitted.out$psi.samples)) +}) + +test_that("predict works for sfJSDM", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) + +test_that("posterior predictive checks work for sfJSDM", { + expect_error(ppcOcc(out, 'chi-square', 2)) +}) + +# Covariates -------------------------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.3, -0.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.4, 3.3) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', factor.model = TRUE, + n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +y <- apply(y, c(1, 2), max, na.rm = TRUE) +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +data.list <- list(y = y, coords = coords, covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(beta.comm = 0, + beta = 0, + tau.sq.beta = 1) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 40 +n.report <- 100 +formula <- ~ occ.cov.1 + occ.cov.2 + +out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfJSDM", { + expect_s3_class(out, "sfJSDM") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfJSDM(formula = formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfJSDM") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- sfJSDM(formula = formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE)) +}) + +test_that("all correlation functions work", { + out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfJSDM") + + out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfJSDM") + + out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfJSDM") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfJSDM", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfJSDM", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$z.samples), "array") + expect_equal(class(fitted.out$psi.samples), "array") + expect_equal(dim(fitted.out$z.samples), dim(fitted.out$psi.samples)) +}) + +test_that("predict works for sfJSDM", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) + +test_that("posterior predictive checks work for sfJSDM", { + expect_error(ppcOcc(out, 'chi-square', 2)) +}) + +# Random intercept -------------------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(0.5)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', factor.model = TRUE, + n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +y <- apply(y, c(1, 2), max, na.rm = TRUE) +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +data.list <- list(y = y, coords = coords, covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(beta.comm = 0, + beta = 0, + tau.sq.beta = 1) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 40 +n.report <- 100 +formula <- ~ (1 | occ.factor.1) + +out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfJSDM", { + expect_s3_class(out, "sfJSDM") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect gives error when non-numeric", { + data.list$covs <- as.data.frame(data.list$covs) + data.list$covs$occ.factor.1 <- factor(data.list$covs$occ.factor.1) + expect_error(out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$covs$occ.factor.1 <- as.character(factor(data.list$covs$occ.factor.1)) + expect_error(out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfJSDM(formula = formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfJSDM") +}) + +test_that("all correlation functions work", { + out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfJSDM") + + out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfJSDM") + + out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfJSDM") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfJSDM", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfJSDM", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$z.samples), "array") + expect_equal(class(fitted.out$psi.samples), "array") + expect_equal(dim(fitted.out$z.samples), dim(fitted.out$psi.samples)) +}) + +test_that("predict works for sfJSDM", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) + +test_that("posterior predictive checks work for sfJSDM", { + expect_error(ppcOcc(out, 'chi-square', 2)) +}) + +# Multiple random intercepts ---------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20, 30), + sigma.sq.psi = c(0.5, 1.5)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', factor.model = TRUE, + n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +y <- apply(y, c(1, 2), max, na.rm = TRUE) +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(beta.comm = 0, + beta = 0, + tau.sq.beta = 1) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 40 +n.report <- 100 +formula <- ~ (1 | occ.factor.1) + (1 | occ.factor.2) + +out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfJSDM", { + expect_s3_class(out, "sfJSDM") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect gives error when non-numeric", { + data.list$covs <- as.data.frame(data.list$covs) + data.list$covs$occ.factor.1 <- factor(data.list$covs$occ.factor.1) + expect_error(out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$covs$occ.factor.1 <- as.character(factor(data.list$covs$occ.factor.1)) + expect_error(out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfJSDM(formula = formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfJSDM") +}) + +test_that("all correlation functions work", { + out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfJSDM") + + out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfJSDM") + + out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfJSDM") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfJSDM", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfJSDM", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$z.samples), "array") + expect_equal(class(fitted.out$psi.samples), "array") + expect_equal(dim(fitted.out$z.samples), dim(fitted.out$psi.samples)) +}) + +test_that("predict works for sfJSDM", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) + +test_that("posterior predictive checks work for sfJSDM", { + expect_error(ppcOcc(out, 'chi-square', 2)) +}) + +# Random effects + covariate effects -------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, -0.5, 0.8) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.2, 2.3) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20, 30), + sigma.sq.psi = c(0.5, 1.5)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', factor.model = TRUE, + n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +y <- apply(y, c(1, 2), max, na.rm = TRUE) +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(beta.comm = 0, + beta = 0, + tau.sq.beta = 1) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 40 +n.report <- 100 +formula <- ~ occ.cov.1 + occ.cov.2 + (1 | occ.factor.1) + (1 | occ.factor.2) + +out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfJSDM", { + expect_s3_class(out, "sfJSDM") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect gives error when non-numeric", { + data.list$covs <- as.data.frame(data.list$covs) + data.list$covs$occ.factor.1 <- factor(data.list$covs$occ.factor.1) + expect_error(out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$covs$occ.factor.1 <- as.character(factor(data.list$covs$occ.factor.1)) + expect_error(out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfJSDM(formula = formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfJSDM") +}) + +test_that("all correlation functions work", { + out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfJSDM") + + out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfJSDM") + + out <- sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfJSDM") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfJSDM(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfJSDM", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfJSDM", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$z.samples), "array") + expect_equal(class(fitted.out$psi.samples), "array") + expect_equal(dim(fitted.out$z.samples), dim(fitted.out$psi.samples)) +}) + +test_that("predict works for sfJSDM", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) + +test_that("posterior predictive checks work for sfJSDM", { + expect_error(ppcOcc(out, 'chi-square', 2)) +}) diff --git a/tests/testthat/test-sfMsPGOcc-NNGP.R b/tests/testthat/test-sfMsPGOcc-NNGP.R new file mode 100644 index 0000000..37dca28 --- /dev/null +++ b/tests/testthat/test-sfMsPGOcc-NNGP.R @@ -0,0 +1,5679 @@ +# Test sfMsPGOcc.R ------------------------------------------------------- +# NNGP -------------------------------------------------------------------- + +skip_on_cran() + +# Intercept Only ---------------------------------------------------------- +set.seed(234) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', factor.model = TRUE, + n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + + +data.list <- list(y = y, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + fix = TRUE, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ 1 + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + out.k.fold <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold.only = TRUE, + k.fold = 2, + k.fold.threads = 1) + expect_equal(length(out.k.fold$k.fold.deviance), N) + expect_type(out.k.fold$k.fold.deviance, "double") + expect_equal(sum(out.k.fold$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE)) +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence coviarate only ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.3) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', factor.model = TRUE, + n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 +det.formula <- ~ 1 + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Detection covariate only ------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Covariates on both ------------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ det.cov.1 + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Interactions on both ---------------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, -0.5, 1.0) +tau.sq.alpha <- c(1, 2.3, 1.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 * occ.cov.2 +det.formula <- ~ det.cov.1 * det.cov.2 + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.0[, 2] * X.0[, 3]) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.cov.1:occ.cov.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + X.p.0 <- cbind(X.p.0, X.p.0[, 2] * X.p.0[, 3]) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Site covariate on detection --------------------------------------------- +set.seed(400) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + occ.cov.1 = X[, 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ occ.cov.1 + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- X.0[, 1, drop = FALSE] + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(1, data.list$det.covs$occ.cov.1) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(X.p.0))) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercept on occurrence ------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45), + sigma.sq.psi = c(1.3)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ 1 + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts on occurrence -------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45, 20), + sigma.sq.psi = c(1.3, 3.4)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence REs + covariates --------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.2, -1.9) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20, 10), + sigma.sq.psi = c(1.3, 3.4)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence REs + covariates in everything ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.2, -1.9) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, 1.2) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20, 10), + sigma.sq.psi = c(1.3, 3.4)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ det.cov.1 + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercept on detection ------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50), + sigma.sq.p = c(2.50)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, 1], dat$X.p.re[, 1, 1]) + colnames(X.p.0) <- c('intercept', 'det.factor.1') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts on detection --------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, 1], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Detection random effects with covariates -------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, 0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Detection random effects with covariates on all ------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.5, 0.3) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 0.5, 3.3) +# Detection +alpha.mean <- c(0, 0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercepts on both ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercepts on both with covariates ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.2, -0.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.4, 0.3) +# Detection +alpha.mean <- c(0, 0.5) +tau.sq.alpha <- c(1, 3.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + (1 | occ.factor.1) +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Third dimension of y != max(n.rep) -------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +n.rep.max <- 7 +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors, n.rep.max = n.rep.max) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ det.cov.1 + +out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class sfMsPGOcc", { + expect_s3_class(out, "sfMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") + + out <- sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "sfMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(sfMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for sfMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for sfMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for sfMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.rep.max)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.rep.max)) +}) + diff --git a/tests/testthat/test-spIntPGOcc-GP.R b/tests/testthat/test-spIntPGOcc-GP.R new file mode 100644 index 0000000..56e2ca6 --- /dev/null +++ b/tests/testthat/test-spIntPGOcc-GP.R @@ -0,0 +1,2244 @@ +# Test spIntPGOcc.R ------------------------------------------------------ +# GP ---------------------------------------------------------------------- +skip_on_cran() + +# Intercept only ---------------------------------------------------------- +set.seed(1010) +J.x <- 10 +J.y <- 10 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(1:4, size = J.obs[i], replace = TRUE) +} +# Occupancy covariates +beta <- c(0.5) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +alpha[[1]] <- runif(1, 0, 1) +alpha[[2]] <- runif(1, 0, 1) +alpha[[3]] <- runif(1, -1, 1) +alpha[[4]] <- runif(1, -1, 1) +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) +sigma.sq <- 2 +phi <- 3 / .5 +sp <- TRUE + +# Simulate occupancy data from multiple data sources. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = sp, + sigma.sq = sigma.sq, phi = phi, cov.model = 'exponential') + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites +X.0 <- dat$X.pred +psi.0 <- dat$psi.pred +coords <- as.matrix(dat$coords.obs) +coords.0 <- as.matrix(dat$coords.pred) + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int.1 = X.p[[1]][, , 1]) +det.covs[[2]] <- list(int.2 = X.p[[2]][, , 1]) +det.covs[[3]] <- list(int.3 = X.p[[3]][, , 1]) +det.covs[[4]] <- list(int.4 = X.p[[4]][, , 1]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + coords = coords) + +J <- length(dat$z.obs) + +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + phi = 3 / .5, + sigma.sq = 2, + w = rep(0, J), + fix = TRUE, + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72)), + phi.unif = c(3/1, 3/.1), + nu.unif = c(0.5, 2), + sigma.sq.ig = c(2, 2)) +# Tuning +tuning.list <- list(phi = 0.3, nu = 0.4) + +# Number of batches +n.batch <- 40 +# Batch length +batch.length <- 25 +n.samples <- n.batch * batch.length +occ.formula <- ~ 1 +det.formula <- list(f.1 = ~ 1, f.2 = ~ 1, f.3 = ~ 1, f.4 = ~ 1) + +out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class spIntPGOcc", { + expect_s3_class(out, "spIntPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors and inits work", { + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + NNGP = FALSE, + n.omp.threads = 1, + verbose = FALSE)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + parallel.chains = FALSE, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check all correlation functions ----- +test_that("all correlation functions work", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spIntPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for spIntPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + coords.0 <- dat$coords.pred + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + +# Occurrence covariate only ----------------------------------------------- +J.x <- 10 +J.y <- 10 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(1:4, size = J.obs[i], replace = TRUE) +} +# Occupancy covariates +beta <- c(0.5, 1.2, -0.5) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +alpha[[1]] <- runif(1, 0, 1) +alpha[[2]] <- runif(1, 0, 1) +alpha[[3]] <- runif(1, -1, 1) +alpha[[4]] <- runif(1, -1, 1) +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) +sigma.sq <- 2 +phi <- 3 / .5 +sp <- TRUE + +# Simulate occupancy data from multiple data sources. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = sp, + sigma.sq = sigma.sq, phi = phi, cov.model = 'exponential') + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites +X.0 <- dat$X.pred +psi.0 <- dat$psi.pred +coords <- as.matrix(dat$coords.obs) +coords.0 <- as.matrix(dat$coords.pred) + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int.1 = X.p[[1]][, , 1]) +det.covs[[2]] <- list(int.2 = X.p[[2]][, , 1]) +det.covs[[3]] <- list(int.3 = X.p[[3]][, , 1]) +det.covs[[4]] <- list(int.4 = X.p[[4]][, , 1]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + coords = coords) + +J <- length(dat$z.obs) + +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + phi = 3 / .5, + sigma.sq = 2, + w = rep(0, J), + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72)), + phi.unif = c(3/1, 3/.1), + sigma.sq.ig = c(2, 2)) +# Tuning +tuning.list <- list(phi = 0.3) + +# Number of batches +n.batch <- 40 +# Batch length +batch.length <- 25 +n.samples <- n.batch * batch.length +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- list(f.1 = ~ 1, f.2 = ~ 1, f.3 = ~ 1, f.4 = ~ 1) + +out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class spIntPGOcc", { + expect_s3_class(out, "spIntPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + parallel.chains = FALSE, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][[1]][1] <- NA + # expect_error(spIntPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[[1]][1, 1] <- NA + # out <- spIntPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1) + # expect_s3_class(out, "spIntPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors and inits work", { + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check all correlation functions ----- +test_that("all correlation functions work", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + parallel.chains = FALSE, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spIntPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for spIntPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + coords.0 <- dat$coords.pred + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + +# Detection covariate only ------------------------------------------------ +J.x <- 10 +J.y <- 10 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(2:4, size = J.obs[i], replace = TRUE) +} +# Occupancy covariates +beta <- c(0.5) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +alpha[[1]] <- runif(2, 0, 1) +alpha[[2]] <- runif(1, 0, 1) +alpha[[3]] <- runif(3, -1, 1) +alpha[[4]] <- runif(2, -1, 1) +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) +sigma.sq <- 2 +phi <- 3 / .5 +sp <- TRUE + +# Simulate occupancy data from multiple data sources. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = sp, + sigma.sq = sigma.sq, phi = phi, cov.model = 'exponential') + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites +X.0 <- dat$X.pred +psi.0 <- dat$psi.pred +coords <- as.matrix(dat$coords.obs) +coords.0 <- as.matrix(dat$coords.pred) + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int.1 = X.p[[1]][, , 1], + det.cov.1.1 = X.p[[1]][, , 2]) +det.covs[[2]] <- list(int.2 = X.p[[2]][, , 1]) +det.covs[[3]] <- list(int.3 = X.p[[3]][, , 1], + det.cov.3.1 = X.p[[3]][, , 2], + det.cov.3.2 = X.p[[3]][, , 3]) +det.covs[[4]] <- list(int.4 = X.p[[4]][, , 1], + det.cov.4.1 = X.p[[4]][, , 2]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + coords = coords) + +J <- length(dat$z.obs) + +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + phi = 3 / .5, + sigma.sq = 2, + w = rep(0, J), + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72)), + phi.unif = c(3/1, 3/.1), + sigma.sq.ig = c(2, 2)) +# Tuning +tuning.list <- list(phi = 0.3) + +# Number of batches +n.batch <- 40 +# Batch length +batch.length <- 25 +n.samples <- n.batch * batch.length +occ.formula <- ~ 1 +det.formula <- list(f.1 = ~ det.cov.1.1, + f.2 = ~ 1, + f.3 = ~ det.cov.3.1 + det.cov.3.2, + f.4 = ~ det.cov.4.1) + +out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class spIntPGOcc", { + expect_s3_class(out, "spIntPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(spIntPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- 1 + tmp.data$det.covs[[1]][[2]][1] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + parallel.chains = FALSE, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- NA + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors and inits work", { + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check all correlation functions ----- +test_that("all correlation functions work", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + parallel.chains = FALSE, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spIntPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for spIntPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + coords.0 <- dat$coords.pred + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + +# Covariates on both ------------------------------------------------------ +J.x <- 10 +J.y <- 10 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(2:4, size = J.obs[i], replace = TRUE) +} +# Occupancy covariates +beta <- c(0.5, 1.2, -0.3) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +alpha[[1]] <- runif(2, 0, 1) +alpha[[2]] <- runif(1, 0, 1) +alpha[[3]] <- runif(3, -1, 1) +alpha[[4]] <- runif(2, -1, 1) +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) +sigma.sq <- 2 +phi <- 3 / .5 +sp <- TRUE + +# Simulate occupancy data from multiple data sources. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = sp, + sigma.sq = sigma.sq, phi = phi, cov.model = 'exponential') + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites +X.0 <- dat$X.pred +psi.0 <- dat$psi.pred +coords <- as.matrix(dat$coords.obs) +coords.0 <- as.matrix(dat$coords.pred) + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int.1 = X.p[[1]][, , 1], + det.cov.1.1 = X.p[[1]][, , 2]) +det.covs[[2]] <- list(int.2 = X.p[[2]][, , 1]) +det.covs[[3]] <- list(int.3 = X.p[[3]][, , 1], + det.cov.3.1 = X.p[[3]][, , 2], + det.cov.3.2 = X.p[[3]][, , 3]) +det.covs[[4]] <- list(int.4 = X.p[[4]][, , 1], + det.cov.4.1 = X.p[[4]][, , 2]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + coords = coords) + +J <- length(dat$z.obs) + +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + phi = 3 / .5, + sigma.sq = 2, + w = rep(0, J), + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72)), + phi.unif = c(3/1, 3/.1), + sigma.sq.ig = c(2, 2)) +# Tuning +tuning.list <- list(phi = 0.3) + +# Number of batches +n.batch <- 40 +# Batch length +batch.length <- 25 +n.samples <- n.batch * batch.length +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- list(f.1 = ~ det.cov.1.1, + f.2 = ~ 1, + f.3 = ~ det.cov.3.1 + det.cov.3.2, + f.4 = ~ det.cov.4.1) + +out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class spIntPGOcc", { + expect_s3_class(out, "spIntPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- 1 + tmp.data$det.covs[[1]][[2]][1] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- NA + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors and inits work", { + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check all correlation functions ----- +test_that("all correlation functions work", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spIntPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for spIntPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + coords.0 <- dat$coords.pred + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + +# Interactions on both ---------------------------------------------------- +J.x <- 10 +J.y <- 10 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(2:4, size = J.obs[i], replace = TRUE) +} +# Occupancy covariates +beta <- c(0.5, 1.2, -0.3) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +alpha[[1]] <- runif(2, 0, 1) +alpha[[2]] <- runif(1, 0, 1) +alpha[[3]] <- runif(3, -1, 1) +alpha[[4]] <- runif(2, -1, 1) +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) +sigma.sq <- 2 +phi <- 3 / .5 +sp <- TRUE + +# Simulate occupancy data from multiple data sources. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = sp, + sigma.sq = sigma.sq, phi = phi, cov.model = 'exponential') + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites +X.0 <- dat$X.pred +psi.0 <- dat$psi.pred +coords <- as.matrix(dat$coords.obs) +coords.0 <- as.matrix(dat$coords.pred) + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int.1 = X.p[[1]][, , 1], + det.cov.1.1 = X.p[[1]][, , 2]) +det.covs[[2]] <- list(int.2 = X.p[[2]][, , 1]) +det.covs[[3]] <- list(int.3 = X.p[[3]][, , 1], + det.cov.3.1 = X.p[[3]][, , 2], + det.cov.3.2 = X.p[[3]][, , 3]) +det.covs[[4]] <- list(int.4 = X.p[[4]][, , 1], + det.cov.4.1 = X.p[[4]][, , 2]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + coords = coords) + +J <- length(dat$z.obs) + +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + phi = 3 / .5, + sigma.sq = 2, + w = rep(0, J), + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72)), + phi.unif = c(3/1, 3/.1), + sigma.sq.ig = c(2, 2)) +# Tuning +tuning.list <- list(phi = 0.3) + +# Number of batches +n.batch <- 40 +# Batch length +batch.length <- 25 +n.samples <- n.batch * batch.length +occ.formula <- ~ occ.cov.1 * occ.cov.2 +det.formula <- list(f.1 = ~ det.cov.1.1, + f.2 = ~ 1, + f.3 = ~ det.cov.3.1 * det.cov.3.2, + f.4 = ~ det.cov.4.1) + +out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class spIntPGOcc", { + expect_s3_class(out, "spIntPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- 1 + tmp.data$det.covs[[1]][[2]][1] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- NA + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors and inits work", { + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check all correlation functions ----- +test_that("all correlation functions work", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spIntPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for spIntPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + X.0 <- cbind(X.0, X.0[, 2] * X.0[, 3]) + coords.0 <- dat$coords.pred + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + +# Model with fixed sigma.sq ----------------------------------------------- +test_that("spIntPGOcc works with fixed sigma.sq", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + priors = list(sigma.sq.ig = "fixed"), + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + expect_equal(length(unique(out$theta.samples[, 1])), 1) +}) + +# Uniform sigma sq -------------------------------------------------------- +test_that("spIntPGOcc works with uniform prior on sigma.sq", { + prior.list <- list(sigma.sq.unif = c(0, 5), + nu.unif = c(0.1, 4)) + tuning.list <- list(phi = 0.5, nu = 0.6, sigma.sq = 0.7) + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + priors = prior.list, + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = prior.list, + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Different max(n.rep) ---------------------------------------------------- +J.x <- 10 +J.y <- 10 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(2:4, size = J.obs[i], replace = TRUE) +} +n.rep.max <- rep(5, n.data) +# Occupancy covariates +beta <- c(0.5, 1.2, -0.3) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +alpha[[1]] <- runif(2, 0, 1) +alpha[[2]] <- runif(1, 0, 1) +alpha[[3]] <- runif(3, -1, 1) +alpha[[4]] <- runif(2, -1, 1) +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) +sigma.sq <- 2 +phi <- 3 / .5 +sp <- TRUE + +# Simulate occupancy data from multiple data sources. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = sp, + sigma.sq = sigma.sq, phi = phi, cov.model = 'exponential', n.rep.max = n.rep.max) + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites +X.0 <- dat$X.pred +psi.0 <- dat$psi.pred +coords <- as.matrix(dat$coords.obs) +coords.0 <- as.matrix(dat$coords.pred) + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int.1 = X.p[[1]][, , 1], + det.cov.1.1 = X.p[[1]][, , 2]) +det.covs[[2]] <- list(int.2 = X.p[[2]][, , 1]) +det.covs[[3]] <- list(int.3 = X.p[[3]][, , 1], + det.cov.3.1 = X.p[[3]][, , 2], + det.cov.3.2 = X.p[[3]][, , 3]) +det.covs[[4]] <- list(int.4 = X.p[[4]][, , 1], + det.cov.4.1 = X.p[[4]][, , 2]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + coords = coords) + +J <- length(dat$z.obs) + +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + phi = 3 / .5, + sigma.sq = 2, + w = rep(0, J), + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72)), + phi.unif = c(3/1, 3/.1), + sigma.sq.ig = c(2, 2)) +# Tuning +tuning.list <- list(phi = 0.3) + +# Number of batches +n.batch <- 40 +# Batch length +batch.length <- 25 +n.samples <- n.batch * batch.length +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- list(f.1 = ~ det.cov.1.1, + f.2 = ~ 1, + f.3 = ~ det.cov.3.1 + det.cov.3.2, + f.4 = ~ det.cov.4.1) + +out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class spIntPGOcc", { + expect_s3_class(out, "spIntPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- 1 + tmp.data$det.covs[[1]][[2]][1] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- NA + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors and inits work", { + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check all correlation functions ----- +test_that("all correlation functions work", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spIntPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for spIntPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + coords.0 <- dat$coords.pred + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + diff --git a/tests/testthat/test-spIntPGOcc-NNGP.R b/tests/testthat/test-spIntPGOcc-NNGP.R new file mode 100644 index 0000000..30a0933 --- /dev/null +++ b/tests/testthat/test-spIntPGOcc-NNGP.R @@ -0,0 +1,2237 @@ +# Test spIntPGOcc.R ------------------------------------------------------ +# NNGP -------------------------------------------------------------------- +skip_on_cran() + +# Intercept only ---------------------------------------------------------- +set.seed(1010) +J.x <- 10 +J.y <- 10 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(1:4, size = J.obs[i], replace = TRUE) +} +# Occupancy covariates +beta <- c(0.5) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +alpha[[1]] <- runif(1, 0, 1) +alpha[[2]] <- runif(1, 0, 1) +alpha[[3]] <- runif(1, -1, 1) +alpha[[4]] <- runif(1, -1, 1) +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) +sigma.sq <- 2 +phi <- 3 / .5 +sp <- TRUE + +# Simulate occupancy data from multiple data sources. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = sp, + sigma.sq = sigma.sq, phi = phi, cov.model = 'exponential') + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites +X.0 <- dat$X.pred +psi.0 <- dat$psi.pred +coords <- as.matrix(dat$coords.obs) +coords.0 <- as.matrix(dat$coords.pred) + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int.1 = X.p[[1]][, , 1]) +det.covs[[2]] <- list(int.2 = X.p[[2]][, , 1]) +det.covs[[3]] <- list(int.3 = X.p[[3]][, , 1]) +det.covs[[4]] <- list(int.4 = X.p[[4]][, , 1]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + coords = coords) + +J <- length(dat$z.obs) + +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + phi = 3 / .5, + sigma.sq = 2, + w = rep(0, J), + fix = TRUE, + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72)), + phi.unif = c(3/1, 3/.1), + sigma.sq.ig = c(2, 2)) +# Tuning +tuning.list <- list(phi = 0.3) + +# Number of batches +n.batch <- 40 +# Batch length +batch.length <- 25 +n.samples <- n.batch * batch.length +occ.formula <- ~ 1 +det.formula <- list(f.1 = ~ 1, f.2 = ~ 1, f.3 = ~ 1, f.4 = ~ 1) + +out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class spIntPGOcc", { + expect_s3_class(out, "spIntPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default priors ---------------- +test_that("default priors and inits work", { + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + n.omp.threads = 1, + verbose = FALSE)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check all correlation functions ----- +test_that("all correlation functions work", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spIntPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for spIntPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + coords.0 <- dat$coords.pred + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + +# Occurrence covariate only ----------------------------------------------- +J.x <- 10 +J.y <- 10 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(1:4, size = J.obs[i], replace = TRUE) +} +# Occupancy covariates +beta <- c(0.5, 1.2, -0.5) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +alpha[[1]] <- runif(1, 0, 1) +alpha[[2]] <- runif(1, 0, 1) +alpha[[3]] <- runif(1, -1, 1) +alpha[[4]] <- runif(1, -1, 1) +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) +sigma.sq <- 2 +phi <- 3 / .5 +sp <- TRUE + +# Simulate occupancy data from multiple data sources. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = sp, + sigma.sq = sigma.sq, phi = phi, cov.model = 'exponential') + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites +X.0 <- dat$X.pred +psi.0 <- dat$psi.pred +coords <- as.matrix(dat$coords.obs) +coords.0 <- as.matrix(dat$coords.pred) + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int.1 = X.p[[1]][, , 1]) +det.covs[[2]] <- list(int.2 = X.p[[2]][, , 1]) +det.covs[[3]] <- list(int.3 = X.p[[3]][, , 1]) +det.covs[[4]] <- list(int.4 = X.p[[4]][, , 1]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + coords = coords) + +J <- length(dat$z.obs) + +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + phi = 3 / .5, + sigma.sq = 2, + w = rep(0, J), + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72)), + phi.unif = c(3/1, 3/.1), + sigma.sq.ig = c(2, 2)) +# Tuning +tuning.list <- list(phi = 0.3) + +# Number of batches +n.batch <- 40 +# Batch length +batch.length <- 25 +n.samples <- n.batch * batch.length +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- list(f.1 = ~ 1, f.2 = ~ 1, f.3 = ~ 1, f.4 = ~ 1) + +out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class spIntPGOcc", { + expect_s3_class(out, "spIntPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + k.fold = 2, + k.fold.data = 1) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][[1]][1] <- NA + # expect_error(spIntPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[[1]][1, 1] <- NA + # out <- spIntPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1) + # expect_s3_class(out, "spIntPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors and inits work", { + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check all correlation functions ----- +test_that("all correlation functions work", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spIntPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for spIntPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + coords.0 <- dat$coords.pred + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + +# Detection covariate only ------------------------------------------------ +J.x <- 10 +J.y <- 10 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(2:4, size = J.obs[i], replace = TRUE) +} +# Occupancy covariates +beta <- c(0.5) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +alpha[[1]] <- runif(2, 0, 1) +alpha[[2]] <- runif(1, 0, 1) +alpha[[3]] <- runif(3, -1, 1) +alpha[[4]] <- runif(2, -1, 1) +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) +sigma.sq <- 2 +phi <- 3 / .5 +sp <- TRUE + +# Simulate occupancy data from multiple data sources. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = sp, + sigma.sq = sigma.sq, phi = phi, cov.model = 'exponential') + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites +X.0 <- dat$X.pred +psi.0 <- dat$psi.pred +coords <- as.matrix(dat$coords.obs) +coords.0 <- as.matrix(dat$coords.pred) + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int.1 = X.p[[1]][, , 1], + det.cov.1.1 = X.p[[1]][, , 2]) +det.covs[[2]] <- list(int.2 = X.p[[2]][, , 1]) +det.covs[[3]] <- list(int.3 = X.p[[3]][, , 1], + det.cov.3.1 = X.p[[3]][, , 2], + det.cov.3.2 = X.p[[3]][, , 3]) +det.covs[[4]] <- list(int.4 = X.p[[4]][, , 1], + det.cov.4.1 = X.p[[4]][, , 2]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + coords = coords) + +J <- length(dat$z.obs) + +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + phi = 3 / .5, + sigma.sq = 2, + w = rep(0, J), + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72)), + phi.unif = c(3/1, 3/.1), + sigma.sq.ig = c(2, 2)) +# Tuning +tuning.list <- list(phi = 0.3) + +# Number of batches +n.batch <- 40 +# Batch length +batch.length <- 25 +n.samples <- n.batch * batch.length +occ.formula <- ~ 1 +det.formula <- list(f.1 = ~ det.cov.1.1, + f.2 = ~ 1, + f.3 = ~ det.cov.3.1 + det.cov.3.2, + f.4 = ~ det.cov.4.1) + +out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class spIntPGOcc", { + expect_s3_class(out, "spIntPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(spIntPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- 1 + tmp.data$det.covs[[1]][[2]][1] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- NA + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors and inits work", { + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check all correlation functions ----- +test_that("all correlation functions work", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spIntPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for spIntPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + coords.0 <- dat$coords.pred + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + +# Covariates on both ------------------------------------------------------ +J.x <- 10 +J.y <- 10 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(2:4, size = J.obs[i], replace = TRUE) +} +# Occupancy covariates +beta <- c(0.5, 1.2, -0.3) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +alpha[[1]] <- runif(2, 0, 1) +alpha[[2]] <- runif(1, 0, 1) +alpha[[3]] <- runif(3, -1, 1) +alpha[[4]] <- runif(2, -1, 1) +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) +sigma.sq <- 2 +phi <- 3 / .5 +sp <- TRUE + +# Simulate occupancy data from multiple data sources. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = sp, + sigma.sq = sigma.sq, phi = phi, cov.model = 'exponential') + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites +X.0 <- dat$X.pred +psi.0 <- dat$psi.pred +coords <- as.matrix(dat$coords.obs) +coords.0 <- as.matrix(dat$coords.pred) + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int.1 = X.p[[1]][, , 1], + det.cov.1.1 = X.p[[1]][, , 2]) +det.covs[[2]] <- list(int.2 = X.p[[2]][, , 1]) +det.covs[[3]] <- list(int.3 = X.p[[3]][, , 1], + det.cov.3.1 = X.p[[3]][, , 2], + det.cov.3.2 = X.p[[3]][, , 3]) +det.covs[[4]] <- list(int.4 = X.p[[4]][, , 1], + det.cov.4.1 = X.p[[4]][, , 2]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + coords = coords) + +J <- length(dat$z.obs) + +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + phi = 3 / .5, + sigma.sq = 2, + w = rep(0, J), + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72)), + phi.unif = c(3/1, 3/.1), + sigma.sq.ig = c(2, 2)) +# Tuning +tuning.list <- list(phi = 0.3) + +# Number of batches +n.batch <- 40 +# Batch length +batch.length <- 25 +n.samples <- n.batch * batch.length +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- list(f.1 = ~ det.cov.1.1, + f.2 = ~ 1, + f.3 = ~ det.cov.3.1 + det.cov.3.2, + f.4 = ~ det.cov.4.1) + +out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class spIntPGOcc", { + expect_s3_class(out, "spIntPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- 1 + tmp.data$det.covs[[1]][[2]][1] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- NA + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors and inits work", { + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check all correlation functions ----- +test_that("all correlation functions work", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spIntPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for spIntPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + coords.0 <- dat$coords.pred + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + +# Interactions on both ---------------------------------------------------- +J.x <- 10 +J.y <- 10 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(2:4, size = J.obs[i], replace = TRUE) +} +# Occupancy covariates +beta <- c(0.5, 1.2, -0.3) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +alpha[[1]] <- runif(2, 0, 1) +alpha[[2]] <- runif(1, 0, 1) +alpha[[3]] <- runif(3, -1, 1) +alpha[[4]] <- runif(2, -1, 1) +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) +sigma.sq <- 2 +phi <- 3 / .5 +sp <- TRUE + +# Simulate occupancy data from multiple data sources. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = sp, + sigma.sq = sigma.sq, phi = phi, cov.model = 'exponential') + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites +X.0 <- dat$X.pred +psi.0 <- dat$psi.pred +coords <- as.matrix(dat$coords.obs) +coords.0 <- as.matrix(dat$coords.pred) + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int.1 = X.p[[1]][, , 1], + det.cov.1.1 = X.p[[1]][, , 2]) +det.covs[[2]] <- list(int.2 = X.p[[2]][, , 1]) +det.covs[[3]] <- list(int.3 = X.p[[3]][, , 1], + det.cov.3.1 = X.p[[3]][, , 2], + det.cov.3.2 = X.p[[3]][, , 3]) +det.covs[[4]] <- list(int.4 = X.p[[4]][, , 1], + det.cov.4.1 = X.p[[4]][, , 2]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + coords = coords) + +J <- length(dat$z.obs) + +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + phi = 3 / .5, + sigma.sq = 2, + w = rep(0, J), + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72)), + phi.unif = c(3/1, 3/.1), + sigma.sq.ig = c(2, 2)) +# Tuning +tuning.list <- list(phi = 0.3) + +# Number of batches +n.batch <- 40 +# Batch length +batch.length <- 25 +n.samples <- n.batch * batch.length +occ.formula <- ~ occ.cov.1 * occ.cov.2 +det.formula <- list(f.1 = ~ det.cov.1.1, + f.2 = ~ 1, + f.3 = ~ det.cov.3.1 * det.cov.3.2, + f.4 = ~ det.cov.4.1) + +out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class spIntPGOcc", { + expect_s3_class(out, "spIntPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- 1 + tmp.data$det.covs[[1]][[2]][1] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- NA + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors and inits work", { + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check all correlation functions ----- +test_that("all correlation functions work", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spIntPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for spIntPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + X.0 <- cbind(X.0, X.0[, 2] * X.0[, 3]) + coords.0 <- dat$coords.pred + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + +# Model with fixed sigma.sq ----------------------------------------------- +test_that("spIntPGOcc works with fixed sigma.sq", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + priors = list(sigma.sq.ig = "fixed"), + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + expect_equal(length(unique(out$theta.samples[, 1])), 1) +}) + +# Uniform sigma sq -------------------------------------------------------- +test_that("spIntPGOcc works with uniform prior on sigma.sq", { + prior.list <- list(sigma.sq.unif = c(0, 5), + nu.unif = c(0.1, 4)) + tuning.list <- list(phi = 0.5, nu = 0.6, sigma.sq = 0.7) + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + priors = prior.list, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = prior.list, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Different max(n.rep) ---------------------------------------------------- +J.x <- 10 +J.y <- 10 +J.all <- J.x * J.y +# Number of data sources. +n.data <- 4 +# Sites for each data source. +J.obs <- sample(ceiling(0.2 * J.all):ceiling(0.5 * J.all), n.data, replace = TRUE) +# Replicates for each data source. +n.rep <- list() +for (i in 1:n.data) { + n.rep[[i]] <- sample(2:4, size = J.obs[i], replace = TRUE) +} +n.rep.max <- rep(5, n.data) +# Occupancy covariates +beta <- c(0.5, 1.2, -0.3) +p.occ <- length(beta) +# Detection covariates +alpha <- list() +alpha[[1]] <- runif(2, 0, 1) +alpha[[2]] <- runif(1, 0, 1) +alpha[[3]] <- runif(3, -1, 1) +alpha[[4]] <- runif(2, -1, 1) +p.det.long <- sapply(alpha, length) +p.det <- sum(p.det.long) +sigma.sq <- 2 +phi <- 3 / .5 +sp <- TRUE + +# Simulate occupancy data from multiple data sources. +dat <- simIntOcc(n.data = n.data, J.x = J.x, J.y = J.y, J.obs = J.obs, + n.rep = n.rep, beta = beta, alpha = alpha, sp = sp, + sigma.sq = sigma.sq, phi = phi, cov.model = 'exponential', n.rep.max = n.rep.max) + +y <- dat$y +X <- dat$X.obs +X.p <- dat$X.p +sites <- dat$sites +X.0 <- dat$X.pred +psi.0 <- dat$psi.pred +coords <- as.matrix(dat$coords.obs) +coords.0 <- as.matrix(dat$coords.pred) + +# Package all data into a list +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list() +# Add covariates one by one +det.covs[[1]] <- list(int.1 = X.p[[1]][, , 1], + det.cov.1.1 = X.p[[1]][, , 2]) +det.covs[[2]] <- list(int.2 = X.p[[2]][, , 1]) +det.covs[[3]] <- list(int.3 = X.p[[3]][, , 1], + det.cov.3.1 = X.p[[3]][, , 2], + det.cov.3.2 = X.p[[3]][, , 3]) +det.covs[[4]] <- list(int.4 = X.p[[4]][, , 1], + det.cov.4.1 = X.p[[4]][, , 2]) +data.list <- list(y = y, + occ.covs = occ.covs, + det.covs = det.covs, + sites = sites, + coords = coords) + +J <- length(dat$z.obs) + +# Initial values +inits.list <- list(alpha = list(0, 0, 0, 0), + beta = 0, + phi = 3 / .5, + sigma.sq = 2, + w = rep(0, J), + z = rep(1, J)) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = list(0, 0, 0, 0), + var = list(2.72, 2.72, 2.72, 2.72)), + phi.unif = c(3/1, 3/.1), + sigma.sq.ig = c(2, 2)) +# Tuning +tuning.list <- list(phi = 0.3) + +# Number of batches +n.batch <- 40 +# Batch length +batch.length <- 25 +n.samples <- n.batch * batch.length +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- list(f.1 = ~ det.cov.1.1, + f.2 = ~ 1, + f.3 = ~ det.cov.3.1 + det.cov.3.2, + f.4 = ~ det.cov.4.1) + +out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class spIntPGOcc", { + expect_s3_class(out, "spIntPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), n.data) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check individual data set cv -------- +test_that("individual data set cv works", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 2, + k.fold = 2, + k.fold.data = 2) + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check output data is correct -------- +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- 1 + tmp.data$det.covs[[1]][[2]][1] <- NA + expect_error(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[[1]][1, 1] <- NA + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check default priors ---------------- +test_that("default priors and inits work", { + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.thin = 1, + n.chains = 1)) +}) + +# Check all correlation functions ----- +test_that("all correlation functions work", { + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") + + out <- spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spIntPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spIntPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spIntPGOcc", { + waic.out <- waicOcc(out) + expect_equal(ncol(waic.out), 3) + expect_equal(nrow(waic.out), n.data) + expect_equal(waic.out[, 3], -2 * (waic.out[, 1] - waic.out[, 2])) +}) + +test_that("fitted works for spIntPGOcc", { + fitted.out <- fitted(out) + expect_equal(class(fitted.out), "list") + expect_equal(length(fitted.out), 2) + expect_equal(length(fitted.out[[1]]), n.data) +}) + +test_that("predict works for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- dat$X.pred + coords.0 <- dat$coords.pred + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, nrow(X.0))) +}) + +test_that("posterior predictive checks work for spIntPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(sapply(ppc.out$fit.y, length), rep(n.post.samples, n.data)) + expect_equal(sapply(ppc.out$fit.y.rep, length), rep(n.post.samples, n.data)) +}) + diff --git a/tests/testthat/test-spMsPGOcc-GP.R b/tests/testthat/test-spMsPGOcc-GP.R new file mode 100644 index 0000000..2cb3763 --- /dev/null +++ b/tests/testthat/test-spMsPGOcc-GP.R @@ -0,0 +1,6447 @@ +# Test spMsPGOcc.R ------------------------------------------------------- +# GP ---------------------------------------------------------------------- + +skip_on_cran() + +# Intercept Only ---------------------------------------------------------- +set.seed(1010) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + + +data.list <- list(y = y, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + fix = TRUE, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ 1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { +out.k.fold <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.only = TRUE, + k.fold.threads = 1) + expect_equal(length(out.k.fold$k.fold.deviance), N) + expect_type(out.k.fold$k.fold.deviance, "double") + expect_equal(sum(out.k.fold$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + NNGP = FALSE, + n.omp.threads = 1, + verbose = FALSE)) +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + parallel.chains = FALSE, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence coviarate only ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.3) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 +det.formula <- ~ 1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[, 1, 1] <- NA + # out <- spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1) + # expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + parallel.chains = FALSE, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Detection covariate only ------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + parallel.chains = FALSE, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Covariates on both ------------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ det.cov.1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Interactions on both ---------------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, -0.5, 1.2) +tau.sq.alpha <- c(1, 2.3, 1.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 * occ.cov.2 +det.formula <- ~ det.cov.1 * det.cov.2 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.0[, 2] * X.0[, 3]) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.cov.1:occ.cov.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + X.p.0 <- cbind(X.p.0, X.p.0[, 2] * X.p.0[, 3]) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Site covariate on detection --------------------------------------------- +set.seed(400) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + occ.cov.1 = X[, 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ occ.cov.1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[2]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- X.0[, 1, drop = FALSE] + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(1, data.list$det.covs$occ.cov.1) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(X.p.0))) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercept on occurrence ------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45), + sigma.sq.psi = c(1.3)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ 1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[, 1, 1] <- NA + # out <- spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1) + # expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts on occurrence -------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45, 20), + sigma.sq.psi = c(1.3, 3.4)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[, 1, 1] <- NA + # out <- spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1) + # expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence REs + covariates --------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.2, -1.9) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20, 10), + sigma.sq.psi = c(1.3, 3.4)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[, 1, 1] <- NA + # out <- spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1) + # expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence REs + covariates in everything ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.2, -1.9) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, 1.2) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20, 10), + sigma.sq.psi = c(1.3, 3.4)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ det.cov.1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercept on detection ------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50), + sigma.sq.p = c(2.50)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, 1], dat$X.p.re[, 1, 1]) + colnames(X.p.0) <- c('intercept', 'det.factor.1') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts on detection --------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, 1], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Detection random effects with covariates -------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, 0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Detection random effects with covariates on all ------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.5, 0.3) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 0.5, 3.3) +# Detection +alpha.mean <- c(0, 0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercepts on both ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercepts on both with covariates ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.2, -0.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.4, 0.3) +# Detection +alpha.mean <- c(0, 0.5) +tau.sq.alpha <- c(1, 3.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + (1 | occ.factor.1) +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Model with fixed sigma.sq ----------------------------------------------- +test_that("spMsPGOcc works with fixed sigma.sq", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(sigma.sq.ig = "fixed"), + cov.model = "exponential", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + expect_equal(length(unique(out$theta.samples[, 1])), 1) +}) + +# Uniform sigma sq -------------------------------------------------------- +test_that("spMsPGOcc works with uniform prior on sigma.sq", { + prior.list <- list(sigma.sq.unif = list(a = 0, b = 5), + nu.unif = list(a = 0.1, b = 4)) + tuning.list <- list(phi = 0.5, nu = 0.6, sigma.sq = 0.7) + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + priors = prior.list, + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = prior.list, + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Third dimension of y != max(n.rep) -------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +n.rep.max <- 7 +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', n.rep.max = n.rep.max) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ det.cov.1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + parallel.chains = FALSE, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.rep.max)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.rep.max)) +}) + diff --git a/tests/testthat/test-spMsPGOcc-NNGP.R b/tests/testthat/test-spMsPGOcc-NNGP.R new file mode 100644 index 0000000..7b8350e --- /dev/null +++ b/tests/testthat/test-spMsPGOcc-NNGP.R @@ -0,0 +1,6441 @@ +# Test spMsPGOcc.R ------------------------------------------------------- +# NNGP -------------------------------------------------------------------- + +skip_on_cran() + +# Intercept Only ---------------------------------------------------------- +set.seed(1010) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + + +data.list <- list(y = y, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + fix = TRUE, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ 1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + out.k.fold <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.only = TRUE, + k.fold.threads = 1) + expect_equal(length(out.k.fold$k.fold.deviance), N) + expect_type(out.k.fold$k.fold.deviance, "double") + expect_equal(sum(out.k.fold$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + n.omp.threads = 1, + verbose = FALSE)) +}) +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence coviarate only ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.3) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 +det.formula <- ~ 1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[, 1, 1] <- NA + # out <- spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1) + # expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Detection covariate only ------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Covariates on both ------------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ det.cov.1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Interactions on both ---------------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, -0.5, 1.2) +tau.sq.alpha <- c(1, 2.3, 1.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 * occ.cov.2 +det.formula <- ~ det.cov.1 * det.cov.2 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.0[, 2] * X.0[, 3]) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.cov.1:occ.cov.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + X.p.0 <- cbind(X.p.0, X.p.0[, 2] * X.p.0[, 3]) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Site covariate on detection --------------------------------------------- +set.seed(400) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + occ.cov.1 = X[, 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ occ.cov.1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[2]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- X.0[, 1, drop = FALSE] + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(1, data.list$det.covs$occ.cov.1) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(X.p.0))) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercept on occurrence ------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45), + sigma.sq.psi = c(1.3)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ 1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[, 1, 1] <- NA + # out <- spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1) + # expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts on occurrence -------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45, 20), + sigma.sq.psi = c(1.3, 3.4)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[, 1, 1] <- NA + # out <- spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1) + # expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence REs + covariates --------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.2, -1.9) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20, 10), + sigma.sq.psi = c(1.3, 3.4)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[, 1, 1] <- NA + # out <- spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1) + # expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence REs + covariates in everything ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.2, -1.9) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, 1.2) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20, 10), + sigma.sq.psi = c(1.3, 3.4)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ det.cov.1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercept on detection ------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50), + sigma.sq.p = c(2.50)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, 1], dat$X.p.re[, 1, 1]) + colnames(X.p.0) <- c('intercept', 'det.factor.1') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts on detection --------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, 1], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Detection random effects with covariates -------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, 0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs[3, ] <- NA + # expect_error(spMsPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Detection random effects with covariates on all ------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.5, 0.3) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 0.5, 3.3) +# Detection +alpha.mean <- c(0, 0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercepts on both ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercepts on both with covariates ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.2, -0.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.4, 0.3) +# Detection +alpha.mean <- c(0, 0.5) +tau.sq.alpha <- c(1, 3.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern') + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + (1 | occ.factor.1) +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Model with fixed sigma.sq ----------------------------------------------- +test_that("spMsPGOcc works with fixed sigma.sq", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(sigma.sq.ig = "fixed"), + cov.model = "exponential", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + expect_equal(length(unique(out$theta.samples[, 1])), 1) +}) + +# Uniform sigma sq -------------------------------------------------------- +test_that("spMsPGOcc works with uniform prior on sigma.sq", { + prior.list <- list(sigma.sq.unif = list(a = 0, b = 5), + nu.unif = list(a = 0.1, b = 4)) + tuning.list <- list(phi = 0.5, nu = 0.6, sigma.sq = 0.7) + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + priors = prior.list, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = prior.list, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Third dimension of y != max(n.rep) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +n.rep.max <- 7 +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +phi <- rep(3 / .7, N) +sigma.sq <- rep(2, N) +nu <- rep(2, N) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', n.rep.max = n.rep.max) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ det.cov.1 + +out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# To make sure it worked -------------- +test_that("out is of class spMsPGOcc", { + expect_s3_class(out, "spMsPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), N) + expect_type(out$k.fold.deviance, "double") + expect_equal(sum(out$k.fold.deviance < 0), 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[, 1, 1] <- NA + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") + + out <- spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "spMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(spMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for spMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for spMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.rep.max)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.rep.max)) +}) + diff --git a/tests/testthat/test-spPGOcc-GP.R b/tests/testthat/test-spPGOcc-GP.R new file mode 100644 index 0000000..a5a7ac7 --- /dev/null +++ b/tests/testthat/test-spPGOcc-GP.R @@ -0,0 +1,5737 @@ +# Test spPGOcc.R --------------------------------------------------------- +# GP ---------------------------------------------------------------------- +skip_on_cran() + +# Intercept only ---------------------------------------------------------- +set.seed(830) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +data.list <- list(y = y, coords = coords) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE), fix = TRUE) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ 1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + NNGP = FALSE, + n.omp.threads = 1, + verbose = FALSE)) +}) +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + parallel.chains = FALSE, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + parallel.chains = FALSE, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Occurrence covariate only ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.9, 1.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ 1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + parallel.chains = FALSE, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[1, 1] <- NA + # out <- spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1) + # expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Detection covariate only ------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.4) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, + det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + parallel.chains = FALSE, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs[3, ] <- NA +# expect_error(spPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = FALSE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 500, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Covariates on both ------------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.8) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.4) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, + det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Interactions on both ---------------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.8, 1.2) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.4) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, + det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 * occ.cov.2 +det.formula <- ~ det.cov.1 * det.cov.2 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0 <- cbind(X.0, X.0[, 2] * X.0[, 3]) + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + X.p.0 <- cbind(X.p.0, X.p.0[, 2] * X.p.0[, 3]) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Site covariate on detection --------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.8) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.4) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3], + occ.cov.1 = X[, 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, + det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ occ.cov.1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs[3, ] <- NA +# expect_error(spPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = FALSE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 500, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[3]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + pred.out <- predict(out, X.0[, 1, drop = FALSE], coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(1, dat$X[, 2]) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Random intercept on occurrence ------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list(levels = c(25), + sigma.sq.psi = c(1.3)) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 10 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ 1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[1, 1] <- NA + # out <- spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1) + # expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- matrix(dat$X.p[, 1, ], ncol = 1) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Multiple random intercepts on occurrence -------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list(levels = c(10, 12), + sigma.sq.psi = c(0.2, 3.5)) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[1, 1] <- NA + # out <- spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1) + # expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0, X.re.0) + colnames(X.0.full) <- c('int', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- matrix(dat$X.p[, 1, ], ncol = 1) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Occurrence REs + covariates --------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.5) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list(levels = c(20, 15), + sigma.sq.psi = c(0.2, 3.5)) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[1, 1] <- NA + # out <- spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = FALSE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1) + # expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0, X.re.0) + colnames(X.0.full) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- matrix(dat$X.p[, 1, ], ncol = 1) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Occurrence REs + covariates in everything ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.5) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.5) +p.det <- length(alpha) +psi.RE <- list(levels = c(20, 15), + sigma.sq.psi = c(0.2, 3.5)) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0, X.re.0) + colnames(X.0.full) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Random intercept on detection ------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list(levels = c(50), + sigma.sq.p = c(2.50)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0) + colnames(X.0.full) <- c('int') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1]) + colnames(X.p.0) <- c('intercept', 'det.factor.1') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Multiple random intercepts on detection --------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list(levels = c(50, 25, 30), + sigma.sq.p = c(2.50, 1.2, 0.3)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs[3, ] <- NA +# expect_error(spPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = FALSE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 500, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0) + colnames(X.0.full) <- c('int') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2', 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Multiple random intercepts with covariates on detection ----------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5, 0.3) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list(levels = c(50, 25, 30), + sigma.sq.p = c(2.50, 1.2, 0.3)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + det.cov.1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs[3, ] <- NA +# expect_error(spPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = FALSE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 500, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0) + colnames(X.0.full) <- c('int') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2', 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Multiple random intercepts with covariates on both ---------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.4) +p.occ <- length(beta) +alpha <- c(-0.5, 0.3) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list(levels = c(50, 25, 30), + sigma.sq.p = c(2.50, 1.2, 0.3)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + det.cov.1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0) + colnames(X.0.full) <- c('int', 'occ.cov.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2', 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Random intercepts on both ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 25, 30), + sigma.sq.p = c(2.50, 1.2, 0.3)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0, X.re.0) + colnames(X.0.full) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2', 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Random intercepts on both with covariates ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.5) +p.occ <- length(beta) +alpha <- c(-0.5, -1.2, 0.9) +p.det <- length(alpha) +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 25, 30), + sigma.sq.p = c(2.50, 1.2, 0.3)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) + occ.cov.1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + det.cov.1 + det.cov.2 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0, X.re.0) + colnames(X.0.full) <- c('int', 'occ.cov.1', 'occ.factor.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.cov.2', + 'det.factor.1', 'det.factor.2', 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Fixed sigma sq ---------------------------------------------------- +test_that("spPGOcc works with fixed sigma.sq", { + prior.list <- list(sigma.sq.ig = 'fixed') + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + priors = prior.list, + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + expect_equal(length(unique(out$theta.samples[, 1])), 1) +}) + +# Uniform sigma sq -------------------------------------------------------- +test_that("spPGOcc works with uniform prior on sigma.sq", { + prior.list <- list(sigma.sq.unif = c(0, 5), + nu.unif = c(0.1, 4)) + tuning.list <- list(phi = 0.5, nu = 0.6, sigma.sq = 0.7) + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + priors = prior.list, + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = prior.list, + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Third dimension of y != max(n.rep) -------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +n.rep.max <- 7 +beta <- c(0.3, 0.8) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.4) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, n.rep.max = n.rep.max) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, + det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = FALSE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = FALSE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.rep.max)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.rep.max)) +}) + +# Test residuals ---------------------- +test_that("residuals works", { + out.resids <- residuals(out, n.post.samples = 10) + expect_type(out.resids, 'list') + expect_equal(length(out.resids), 2) +}) + diff --git a/tests/testthat/test-spPGOcc-NNGP.R b/tests/testthat/test-spPGOcc-NNGP.R new file mode 100644 index 0000000..d3cf8a7 --- /dev/null +++ b/tests/testthat/test-spPGOcc-NNGP.R @@ -0,0 +1,5733 @@ +# Test spPGOcc.R --------------------------------------------------------- +# NNGP -------------------------------------------------------------------- +skip_on_cran() + +# Intercept only ---------------------------------------------------------- +set.seed(237) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +data.list <- list(y = y, coords = coords) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE), fix = TRUE) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ 1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + NNGP = TRUE, + n.omp.threads = 1, + verbose = FALSE)) +}) +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Occurrence covariate only ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.9, 1.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ 1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[1, 1] <- NA + # out <- spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1) + # expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Detection covariate only ------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.4) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, + det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs[3, ] <- NA +# expect_error(spPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 500, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Covariates on both ------------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.8) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.4) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, + det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Interactions on both ---------------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.8, 1.2) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.4) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, + det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 * occ.cov.2 +det.formula <- ~ det.cov.1 * det.cov.2 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0 <- cbind(X.0, X.0[, 2] * X.0[, 3]) + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + X.p.0 <- cbind(X.p.0, X.p.0[, 2] * X.p.0[, 3]) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Site covariate on detection --------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.8) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.4) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3], + occ.cov.1 = X[, 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, + det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ occ.cov.1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs[3, ] <- NA +# expect_error(spPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 500, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[3]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + pred.out <- predict(out, X.0[, 1, drop = FALSE], coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(1, dat$X[, 2]) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Random intercept on occurrence ------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list(levels = c(25), + sigma.sq.psi = c(1.3)) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 10 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ 1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[1, 1] <- NA + # out <- spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1) + # expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- matrix(dat$X.p[, 1, ], ncol = 1) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Multiple random intercepts on occurrence -------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list(levels = c(10, 12), + sigma.sq.psi = c(0.2, 3.5)) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[1, 1] <- NA + # out <- spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1) + # expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0, X.re.0) + colnames(X.0.full) <- c('int', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- matrix(dat$X.p[, 1, ], ncol = 1) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Occurrence REs + covariates --------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.5) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list(levels = c(20, 15), + sigma.sq.psi = c(0.2, 3.5)) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[1, 1] <- NA + # out <- spPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1) + # expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0, X.re.0) + colnames(X.0.full) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- matrix(dat$X.p[, 1, ], ncol = 1) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Occurrence REs + covariates in everything ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.5) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.5) +p.det <- length(alpha) +psi.RE <- list(levels = c(20, 15), + sigma.sq.psi = c(0.2, 3.5)) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0, X.re.0) + colnames(X.0.full) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Random intercept on detection ------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list(levels = c(50), + sigma.sq.p = c(2.50)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0) + colnames(X.0.full) <- c('int') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1]) + colnames(X.p.0) <- c('intercept', 'det.factor.1') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Multiple random intercepts on detection --------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list(levels = c(50, 25, 30), + sigma.sq.p = c(2.50, 1.2, 0.3)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs[3, ] <- NA +# expect_error(spPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 500, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0) + colnames(X.0.full) <- c('int') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2', 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Multiple random intercepts with covariates on detection ----------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5, 0.3) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list(levels = c(50, 25, 30), + sigma.sq.p = c(2.50, 1.2, 0.3)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + det.cov.1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs[3, ] <- NA +# expect_error(spPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 500, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0) + colnames(X.0.full) <- c('int') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2', 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Multiple random intercepts with covariates on both ---------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.4) +p.occ <- length(beta) +alpha <- c(-0.5, 0.3) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list(levels = c(50, 25, 30), + sigma.sq.p = c(2.50, 1.2, 0.3)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + det.cov.1 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0) + colnames(X.0.full) <- c('int', 'occ.cov.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2', 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Random intercepts on both ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 25, 30), + sigma.sq.p = c(2.50, 1.2, 0.3)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0, X.re.0) + colnames(X.0.full) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2', 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Random intercepts on both with covariates ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.5) +p.occ <- length(beta) +alpha <- c(-0.5, -1.2, 0.9) +p.det <- length(alpha) +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 25, 30), + sigma.sq.p = c(2.50, 1.2, 0.3)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) + occ.cov.1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + det.cov.1 + det.cov.2 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + X.0.full <- cbind(X.0, X.re.0) + colnames(X.0.full) <- c('int', 'occ.cov.1', 'occ.factor.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.cov.2', + 'det.factor.1', 'det.factor.2', 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Fixed sigma sq ---------------------------------------------------- +test_that("spPGOcc works with fixed sigma.sq", { + prior.list <- list(sigma.sq.ig = 'fixed') + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + priors = prior.list, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + expect_equal(length(unique(out$theta.samples[, 1])), 1) +}) + +# Uniform sigma sq -------------------------------------------------------- +test_that("spPGOcc works with uniform prior on sigma.sq", { + prior.list <- list(sigma.sq.unif = c(0, 5), + nu.unif = c(0.1, 4)) + tuning.list <- list(phi = 0.5, nu = 0.6, sigma.sq = 0.7) + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + priors = prior.list, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = prior.list, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Third dimension of y != max(n.rep) -------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +n.rep.max <- 7 +beta <- c(0.3, 0.8) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.4) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, n.rep.max = n.rep.max) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, + det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class spPGOcc", { + expect_s3_class(out, "spPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("all correlation functions work", { + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") + + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = c(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- spPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "spPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for spPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for spPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for spPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for spPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.rep.max)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.rep.max)) +}) + +# Test residuals ---------------------- +test_that("residuals works", { + out.resids <- residuals(out, n.post.samples = 10) + expect_type(out.resids, 'list') + expect_equal(length(out.resids), 2) +}) + diff --git a/tests/testthat/test-stMsPGOcc.R b/tests/testthat/test-stMsPGOcc.R new file mode 100644 index 0000000..1055054 --- /dev/null +++ b/tests/testthat/test-stMsPGOcc.R @@ -0,0 +1,2206 @@ +# Test stMsPGOcc.R --------------------------------------------------------- + +skip_on_cran() + +# Intercept Only ---------------------------------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4) +tau.sq.beta <- c(1) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1) +tau.sq.alpha <- c(0.5) +p.det <- length(alpha.mean) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +ar1 <- TRUE +sp <- TRUE +svc.cols <- c(1) +p.svc <- length(svc.cols) +n.factors <- 2 +phi <- runif(p.svc * n.factors, 3 / .9, 3 / .3) +factor.model <- TRUE +sigma.sq.t <- runif(N, 0.1, 2) +rho <- runif(N, 0.2, 1) +cov.model <- 'exponential' +range.probs <- runif(N, 0.5, 1) + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho, sp = sp, + svc.cols = svc.cols, n.factors = n.factors, phi = phi, + cov.model = cov.model) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- dat$coords[-pred.indx, ] +coords.0 <- dat$coords[pred.indx, ] +range.ind <- dat$range.ind[, -pred.indx] +range.ind.0 <- dat$range.ind[, pred.indx] + +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + phi.unif = list(a = 3 / 1, 3 / .1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ 1 +det.formula <- ~ 1 + +out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.neighbors = 5, + NNGP = TRUE, + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class stMsPGOcc", { + expect_s3_class(out, "stMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y[, -pred.indx, , ]) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + n.factors = n.factors, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "stMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = 1, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +test_that("all correlation functions work", { + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") + + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") + + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") +}) + + +# Check waicOcc ----------------------- +test_that("waicOCC works for stMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for stMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stMsPGOcc", { + pred.out <- predict(out, X.0, coords.0 = coords.0, t.cols = 1:n.time.max, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- array(X.p.0[, , 1, ], dim = c(nrow(X.p.0), 1, p.det)) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(coords.0), 1)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for stMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Occurrence covariate only ----------------------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4, -0.5) +tau.sq.beta <- c(1, 0.8) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1) +tau.sq.alpha <- c(0.5) +p.det <- length(alpha.mean) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +ar1 <- TRUE +sp <- TRUE +svc.cols <- c(1) +p.svc <- length(svc.cols) +n.factors <- 2 +phi <- runif(p.svc * n.factors, 3 / .9, 3 / .3) +factor.model <- TRUE +sigma.sq.t <- runif(N, 0.1, 2) +rho <- runif(N, 0.2, 1) +cov.model <- 'exponential' +range.probs <- runif(N, 0.5, 1) + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho, sp = sp, + svc.cols = svc.cols, n.factors = n.factors, phi = phi, + cov.model = cov.model) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- dat$coords[-pred.indx, ] +coords.0 <- dat$coords[pred.indx, ] +range.ind <- dat$range.ind[, -pred.indx] +range.ind.0 <- dat$range.ind[, pred.indx] + +occ.covs <- list(occ.cov.1 = X[, , 2]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + phi.unif = list(a = 3 / 1, 3 / .1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ occ.cov.1 +det.formula <- ~ 1 + +out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.neighbors = 5, + NNGP = TRUE, + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class stMsPGOcc", { + expect_s3_class(out, "stMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y[, -pred.indx, , ]) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + n.factors = n.factors, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "stMsPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = 1, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +test_that("all correlation functions work", { + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") + + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") + + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") +}) + + +# Check waicOcc ----------------------- +test_that("waicOCC works for stMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for stMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stMsPGOcc", { + pred.out <- predict(out, X.0, coords.0 = coords.0, t.cols = 1:n.time.max, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- array(X.p.0[, , 1, ], dim = c(nrow(X.p.0), 1, p.det)) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(coords.0), 1)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for stMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Detection covariate only ------------------------------------------------ +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4) +tau.sq.beta <- c(1) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1, 0.5) +tau.sq.alpha <- c(0.5, 1) +p.det <- length(alpha.mean) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +ar1 <- TRUE +sp <- TRUE +svc.cols <- c(1) +p.svc <- length(svc.cols) +n.factors <- 2 +phi <- runif(p.svc * n.factors, 3 / .9, 3 / .3) +factor.model <- TRUE +sigma.sq.t <- runif(N, 0.1, 2) +rho <- runif(N, 0.2, 1) +cov.model <- 'exponential' +range.probs <- runif(N, 0.5, 1) + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho, sp = sp, + svc.cols = svc.cols, n.factors = n.factors, phi = phi, + cov.model = cov.model) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- dat$coords[-pred.indx, ] +coords.0 <- dat$coords[pred.indx, ] +range.ind <- dat$range.ind[, -pred.indx] +range.ind.0 <- dat$range.ind[, pred.indx] + +occ.covs <- list(int = X[, , 1]) +det.covs <- list(det.cov.1 = X.p[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + phi.unif = list(a = 3 / 1, 3 / .1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + +out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.neighbors = 5, + NNGP = TRUE, + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class stMsPGOcc", { + expect_s3_class(out, "stMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y[, -pred.indx, , ]) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + n.factors = n.factors, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "stMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = 1, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +test_that("all correlation functions work", { + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") + + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") + + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") +}) + + +# Check waicOcc ----------------------- +test_that("waicOCC works for stMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for stMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stMsPGOcc", { + pred.out <- predict(out, X.0, coords.0 = coords.0, t.cols = 1:n.time.max, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- array(X.p.0[, , 1, ], dim = c(nrow(X.p.0), 1, p.det)) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(coords.0), 1)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for stMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Covariates on both ------------------------------------------------------ +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4, -0.9, 0.5, 0.2) +tau.sq.beta <- c(1, 0.5, 1.2, 0.5) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1, 0.5) +tau.sq.alpha <- c(0.5, 1) +p.det <- length(alpha.mean) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +ar1 <- TRUE +sp <- TRUE +svc.cols <- c(1) +p.svc <- length(svc.cols) +n.factors <- 2 +phi <- runif(p.svc * n.factors, 3 / .9, 3 / .3) +factor.model <- TRUE +sigma.sq.t <- runif(N, 0.1, 2) +rho <- runif(N, 0.2, 1) +cov.model <- 'exponential' +range.probs <- runif(N, 0.5, 1) + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho, sp = sp, + svc.cols = svc.cols, n.factors = n.factors, phi = phi, + cov.model = cov.model) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- dat$coords[-pred.indx, ] +coords.0 <- dat$coords[pred.indx, ] +range.ind <- dat$range.ind[, -pred.indx] +range.ind.0 <- dat$range.ind[, pred.indx] + +occ.covs <- list(occ.cov.1 = X[, , 2], + occ.cov.2 = X[, , 3], + occ.cov.3 = X[, , 4]) +det.covs <- list(det.cov.1 = X.p[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + phi.unif = list(a = 3 / 1, 3 / .1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + occ.cov.3 +det.formula <- ~ det.cov.1 + +out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.neighbors = 5, + NNGP = TRUE, + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class stMsPGOcc", { + expect_s3_class(out, "stMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y[, -pred.indx, , ]) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + n.factors = n.factors, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "stMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = 1, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +test_that("all correlation functions work", { + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") + + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") + + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") +}) + + +# Check waicOcc ----------------------- +test_that("waicOCC works for stMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for stMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stMsPGOcc", { + pred.out <- predict(out, X.0, coords.0 = coords.0, t.cols = 1:n.time.max, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- array(X.p.0[, , 1, ], dim = c(nrow(X.p.0), 1, p.det)) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(coords.0), 1)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for stMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + + +# Interactions on both ---------------------------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4, -0.9, 0.5, 0.2) +tau.sq.beta <- c(1, 0.5, 1.2, 0.5) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1, 0.5, 0.2) +tau.sq.alpha <- c(0.5, 1, 0.3) +p.det <- length(alpha.mean) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +ar1 <- TRUE +sp <- TRUE +svc.cols <- c(1) +p.svc <- length(svc.cols) +n.factors <- 2 +phi <- runif(p.svc * n.factors, 3 / .9, 3 / .3) +factor.model <- TRUE +sigma.sq.t <- runif(N, 0.1, 2) +rho <- runif(N, 0.2, 1) +cov.model <- 'exponential' +range.probs <- runif(N, 0.5, 1) + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho, sp = sp, + svc.cols = svc.cols, n.factors = n.factors, phi = phi, + cov.model = cov.model) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- dat$coords[-pred.indx, ] +coords.0 <- dat$coords[pred.indx, ] +range.ind <- dat$range.ind[, -pred.indx] +range.ind.0 <- dat$range.ind[, pred.indx] + +occ.covs <- list(occ.cov.1 = X[, , 2], + occ.cov.2 = X[, , 3], + occ.cov.3 = X[, , 4]) +det.covs <- list(det.cov.1 = X.p[, , , 2], + det.cov.2 = X.p[, , , 3]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + phi.unif = list(a = 3 / 1, 3 / .1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ occ.cov.1 + occ.cov.2 * occ.cov.3 +det.formula <- ~ det.cov.1 * det.cov.2 + +out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.neighbors = 5, + NNGP = TRUE, + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class stMsPGOcc", { + expect_s3_class(out, "stMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y[, -pred.indx, , ]) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + n.factors = n.factors, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "stMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = 1, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +test_that("all correlation functions work", { + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") + + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") + + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for stMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stMsPGOcc", { + X.0 <- abind(X.0, X.0[, , 3] * X.0[, , 4], along = 3) + dimnames(X.0)[[3]] <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.cov.3', + 'occ.cov.2:occ.cov.3') + pred.out <- predict(out, X.0, coords.0 = coords.0, t.cols = 1:n.time.max, + verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, , 1, ] + X.p.0 <- abind(X.p.0, X.p.0[, , 2] * X.p.0[, , 3], along = 3) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for stMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Site-level covariate on detection --------------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4, -0.9, 0.5, 0.2) +tau.sq.beta <- c(1, 0.5, 1.2, 0.5) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1, 0.5) +tau.sq.alpha <- c(0.5, 1) +p.det <- length(alpha.mean) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +ar1 <- TRUE +sp <- TRUE +svc.cols <- c(1) +p.svc <- length(svc.cols) +n.factors <- 2 +phi <- runif(p.svc * n.factors, 3 / .9, 3 / .3) +factor.model <- TRUE +sigma.sq.t <- runif(N, 0.1, 2) +rho <- runif(N, 0.2, 1) +cov.model <- 'exponential' +range.probs <- runif(N, 0.5, 1) + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho, sp = sp, + svc.cols = svc.cols, n.factors = n.factors, phi = phi, + cov.model = cov.model) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- dat$coords[-pred.indx, ] +coords.0 <- dat$coords[pred.indx, ] +range.ind <- dat$range.ind[, -pred.indx] +range.ind.0 <- dat$range.ind[, pred.indx] + +occ.covs <- list(occ.cov.1 = X[, , 2], + occ.cov.2 = X[, , 3], + occ.cov.3 = X[, , 4]) +det.covs <- list(det.cov.1 = X[, , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + phi.unif = list(a = 3 / 1, 3 / .1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + occ.cov.3 +det.formula <- ~ det.cov.1 + +out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.neighbors = 5, + NNGP = TRUE, + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class stMsPGOcc", { + expect_s3_class(out, "stMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y[, -pred.indx, , ]) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + n.factors = n.factors, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "stMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = 1, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +test_that("all correlation functions work", { + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") + + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") + + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") +}) + + +# Check waicOcc ----------------------- +test_that("waicOCC works for stMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for stMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stMsPGOcc", { + pred.out <- predict(out, X.0, coords.0 = coords.0, t.cols = 1:n.time.max, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- X.0[, , 1:2] + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(coords.0), n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for stMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Covariates and random effects on both ----------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4, -0.9, 0.5, 0.2) +tau.sq.beta <- c(1, 0.5, 1.2, 0.5) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +alpha.mean <- c(-1, 0.5) +tau.sq.alpha <- c(0.5, 1) +p.det <- length(alpha.mean) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +ar1 <- TRUE +sp <- TRUE +svc.cols <- c(1) +p.svc <- length(svc.cols) +n.factors <- 2 +phi <- runif(p.svc * n.factors, 3 / .9, 3 / .3) +factor.model <- TRUE +sigma.sq.t <- runif(N, 0.1, 2) +rho <- runif(N, 0.2, 1) +cov.model <- 'exponential' +range.probs <- runif(N, 0.5, 1) + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho, sp = sp, + svc.cols = svc.cols, n.factors = n.factors, phi = phi, + cov.model = cov.model) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- dat$coords[-pred.indx, ] +coords.0 <- dat$coords[pred.indx, ] +range.ind <- dat$range.ind[, -pred.indx] +range.ind.0 <- dat$range.ind[, pred.indx] + +occ.covs <- list(occ.cov.1 = X[, , 2], + occ.cov.2 = X[, , 3], + occ.cov.3 = X[, , 4], + occ.factor.1 = X.re[, , 1]) +det.covs <- list(det.cov.1 = X.p[, , , 2], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + phi.unif = list(a = 3 / 1, 3 / .1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + occ.cov.3 + (1 | occ.factor.1) +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.neighbors = 5, + NNGP = TRUE, + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class stMsPGOcc", { + expect_s3_class(out, "stMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 0, + n.thin = 1, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 0, + n.thin = 1, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y[, -pred.indx, , ]) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + n.factors = n.factors, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "stMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = 1, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +test_that("all correlation functions work", { + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") + + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") + + out <- stMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "stMsPGOcc") +}) + + +# Check waicOcc ----------------------- +test_that("waicOCC works for stMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for stMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stMsPGOcc", { + X.0 <- abind(X.0, X.re.0, along = 3) + dimnames(X.0)[[3]] <- c('(Intercept)', 'occ.cov.1', 'occ.cov.2', 'occ.cov.3', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0 = coords.0, t.cols = 1:n.time.max, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind(X.p.0[, , 1, ], X.p.re.0[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', + 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(coords.0), n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for stMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + diff --git a/tests/testthat/test-stPGOcc-NNGP.R b/tests/testthat/test-stPGOcc-NNGP.R new file mode 100644 index 0000000..c600a48 --- /dev/null +++ b/tests/testthat/test-stPGOcc-NNGP.R @@ -0,0 +1,6181 @@ +# Test stPGOcc.R --------------------------------------------------------- +# NNGP -------------------------------------------------------------------- +skip_on_cran() + +# Intercept only ---------------------------------------------------------- +set.seed(150) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ 1 + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + n.omp.threads = 1, + verbose = FALSE)) +}) +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +# test_that("random effect gives error when non-numeric", { +# data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) +# data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) +# expect_error(out <- stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) +# data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) +# expect_error(out <- stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# }) + +# Check RE levels --------------------- +# test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +# }) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs$trend[3, ] <- NA + # expect_error(stPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + # expect_error(stPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1') + X.0.full <- X.0 + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + # X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + # dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + X.p.0 <- array(dat$X.p[, , 1, ], dim = c(J, n.time.max, p.det)) + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Occurrence covariate only ----------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.8) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1], + trend = X[, , 2]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ trend +det.formula <- ~ 1 + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 1, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +# test_that("random effect gives error when non-numeric", { +# data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) +# data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) +# expect_error(out <- stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) +# data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) +# expect_error(out <- stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# }) + +# Check RE levels --------------------- +# test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +# }) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + ar1 = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + # expect_error(stPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + X.0.full <- X.0 + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)) + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Detection covariate only ------------------------------------------------ +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5, -0.4) +p.det <- length(alpha) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.cov.2 = X.p[, , , 3]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +# test_that("random effect gives error when non-numeric", { +# data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) +# data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) +# expect_error(out <- stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) +# data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) +# expect_error(out <- stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# }) + +# Check RE levels --------------------- +# test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +# }) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs$trend[3, ] <- NA +# expect_error(stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + X.0.full <- X.0 + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, , 1, ] + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Covariates on both ------------------------------------------------------ +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.4) +p.occ <- length(beta) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5, -0.4) +p.det <- length(alpha) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1], + occ.cov.1 = X[, , 2]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.cov.2 = X.p[, , , 3]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +# test_that("random effect gives error when non-numeric", { +# data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) +# data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) +# expect_error(out <- stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) +# data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) +# expect_error(out <- stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# }) + +# Check RE levels --------------------- +# test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +# }) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$occ.cov.1[3, ] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + X.0.full <- X.0 + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, , 1, ] + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Interactions on both ---------------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.4, 0.2) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5, -0.4) +p.det <- length(alpha) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.cov.1 = X[, , 3]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.cov.2 = X.p[, , , 3]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ trend * occ.cov.1 +det.formula <- ~ det.cov.1 * det.cov.2 + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +# test_that("random effect gives error when non-numeric", { +# data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) +# data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) +# expect_error(out <- stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) +# data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) +# expect_error(out <- stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# }) + +# Check RE levels --------------------- +# test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +# }) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + X.0.full <- abind(X.0, X.0[, , 3, drop = FALSE] * X.0[, , 2, drop = FALSE]) + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, , 1, ] + X.p.0 <- abind(X.p.0, X.p.0[, , 2, drop = FALSE] * X.p.0[, , 3, drop = FALSE]) + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Site covariate on detection --------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5) +p.det <- length(alpha) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1], + trend = X[, , 2]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + trend = X[, , 2]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ trend +det.formula <- ~ trend + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +# test_that("random effect gives error when non-numeric", { +# data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) +# data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) +# expect_error(out <- stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) +# data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) +# expect_error(out <- stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# }) + +# Check RE levels --------------------- +# test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +# }) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + ar1 = TRUE, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$trend[1, 1] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + X.0.full <- X.0 + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, , 1, ] + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + + +# Random intercept on occurrence ------------------------------------------ +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10), + sigma.sq.psi = c(0.8)) +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1], + occ.factor.1 = X.re[, , 1]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ 1 + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + #data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs$trend[3, ] <- NA + # expect_error(stPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + # expect_error(stPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'occ.factor.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + # X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + X.p.0 <- array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)) + # dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Multiple random intercepts on occurrence -------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10, 15), + sigma.sq.psi = c(0.8, 0.3)) +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1], + occ.factor.1 = X.re[, , 1], + occ.factor.2 = X.re[, , 2]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + #data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs$trend[3, ] <- NA + # expect_error(stPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + # expect_error(stPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + # X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + X.p.0 <- array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)) + # dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Occurrence REs + covariates --------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.5) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10, 15), + sigma.sq.psi = c(0.8, 0.3)) +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.factor.1 = X.re[, , 1], + occ.factor.2 = X.re[, , 2]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ trend + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + #data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + ar1 = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + # expect_error(stPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + # X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + X.p.0 <- array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)) + # dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Occurrence REs + covariates on both ------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.5) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10, 15), + sigma.sq.psi = c(0.8, 0.3)) +alpha <- c(-1, 0.5) +p.det <- length(alpha) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.factor.1 = X.re[, , 1], + occ.factor.2 = X.re[, , 2]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ trend + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ det.cov.1 + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + #data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + ar1 = TRUE, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + # X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + X.p.0 <- dat$X.p[, , 1, ] + # dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Random intercept on detection ------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list(levels = c(20), + sigma.sq.p = c(1)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.factor.1 = X.p.re[, , , 1]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs$trend[3, ] <- NA +# expect_error(stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.chains = 1)) +# tmp.data <- data.list +# tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA +# expect_error(stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1') + X.0.full <- X.0 + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind::abind(array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)), + dat$X.p.re[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.factor.1') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Multiple random intercepts on detection --------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list(levels = c(20, 15), + sigma.sq.p = c(1, 0.5)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs$trend[3, ] <- NA +# expect_error(stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.chains = 1)) +# tmp.data <- data.list +# tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA +# expect_error(stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1') + X.0.full <- X.0 + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind::abind(array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)), + dat$X.p.re[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Random detection intercepts + detection covariates ---------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5) +p.det <- length(alpha) +p.RE <- list(levels = c(20, 15), + sigma.sq.p = c(1, 0.5)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs$trend[3, ] <- NA +# expect_error(stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1') + X.0.full <- X.0 + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Random detection intercepts + covariates -------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.5) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5) +p.det <- length(alpha) +p.RE <- list(levels = c(20, 15), + sigma.sq.p = c(1, 0.5)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1], + trend = X[, , 2]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ trend +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1') + X.0.full <- X.0 + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Random intercepts on both ----------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10), + sigma.sq.psi = c(0.8)) +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list(levels = c(20), + sigma.sq.p = c(0.4)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1], + occ.factor.1 = X.re[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.factor.1 = X.p.re[, , , 1]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ (1 | det.factor.1) + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs$trend[3, ] <- NA + # expect_error(stPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + # expect_error(stPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'occ.factor.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + # X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + X.p.0 <- abind::abind(array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)), + array(dat$X.p.re[, , 1, ], dim = c(J, n.time.max, 1)), along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.factor.1') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) +# Random intercepts on both with covariates ------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.8) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10), + sigma.sq.psi = c(0.8)) +alpha <- c(-1, 0.5) +p.det <- length(alpha) +p.RE <- list(levels = c(20, 15), + sigma.sq.p = c(1, 0.5)) +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.factor.1 = X.re[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ trend + (1 | occ.factor.1) +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + ar1 = TRUE, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Third dimension of y != max(n.rep) -------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +n.rep.max <- 7 +beta <- c(0.4, 0.4) +p.occ <- length(beta) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5, -0.4) +p.det <- length(alpha) +p.RE <- list() +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, n.rep.max = n.rep.max) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx] + +occ.covs <- list(int = X[, , 1], + occ.cov.1 = X[, , 2]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.cov.2 = X.p[, , , 3]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = c(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class stPGOcc", { + expect_s3_class(out, "stPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +# test_that("random effect gives error when non-numeric", { +# data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) +# data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) +# expect_error(out <- stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) +# data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) +# expect_error(out <- stPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# }) + +# Check RE levels --------------------- +# test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +# }) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("all correlation functions work", { + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") + + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$occ.cov.1[3, ] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- stPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "stPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for stPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for stPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for stPGOcc", { + X.0.full <- X.0 + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, , 1, ] + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, n.rep.max)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, n.rep.max)) +}) + diff --git a/tests/testthat/test-svcMsPGOcc-NNGP.R b/tests/testthat/test-svcMsPGOcc-NNGP.R new file mode 100644 index 0000000..728e61d --- /dev/null +++ b/tests/testthat/test-svcMsPGOcc-NNGP.R @@ -0,0 +1,5615 @@ +# Test svcMsPGOcc.R ------------------------------------------------------- +# NNGP -------------------------------------------------------------------- + +skip_on_cran() + +# Intercept Only ---------------------------------------------------------- +set.seed(883) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +svc.cols <- c(1) +p.svc <- length(svc.cols) +phi <- rep(3 / .7, n.factors * p.svc) +nu <- rep(2, n.factors * p.svc) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', factor.model = TRUE, + n.factors = n.factors, svc.cols = svc.cols) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + + +data.list <- list(y = y, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + fix = TRUE, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ 1 + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + n.factors = 3, + svc.cols = svc.cols, + n.omp.threads = 1, + verbose = FALSE)) +}) +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + svc.cols = svc.cols, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + svc.cols = svc.cols, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence coviarate only ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.3) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +svc.cols <- c(1, 2) +p.svc <- length(svc.cols) +n.factors <- 3 +phi <- runif(n.factors * p.svc, 3 / .9, 3 / .1) +nu <- rep(1, n.factors * p.svc) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', factor.model = TRUE, + n.factors = n.factors, svc.cols = svc.cols) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 +det.formula <- ~ 1 + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 1, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + svc.cols = svc.cols, + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Detection covariate only ------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +svc.cols <- 1 +p.svc <- length(svc.cols) +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + svc.cols = svc.cols, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + svc.cols = svc.cols, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Covariates on both ------------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +svc.cols <- c(1, 3) +p.svc <- length(svc.cols) +n.factors <- 3 +phi <- rep(3 / .7, n.factors * p.svc) +sigma.sq <- rep(2, n.factors * p.svc) +nu <- rep(2, n.factors * p.svc) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', svc.cols = svc.cols, + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ det.cov.1 + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +test_that("getSVCSamples works", { + svc.samples <- getSVCSamples(out) + expect_equal(length(svc.samples), p.svc) +}) + +# Interactions on both ---------------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, -0.5, 1.0) +tau.sq.alpha <- c(1, 2.3, 1.5) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +svc.cols <- c(2, 3) +p.svc <- length(svc.cols) +phi <- rep(3 / .7, n.factors * p.svc) +sigma.sq <- rep(2, n.factors * p.svc) +nu <- rep(2, n.factors * p.svc) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', svc.cols = svc.cols, + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 * occ.cov.2 +det.formula <- ~ det.cov.1 * det.cov.2 + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + svc.cols = svc.cols, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + svc.cols = svc.cols, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.0[, 2] * X.0[, 3]) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.cov.1:occ.cov.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + X.p.0 <- cbind(X.p.0, X.p.0[, 2] * X.p.0[, 3]) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Site covariate on detection --------------------------------------------- +set.seed(400) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2, -0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3, 0.5) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +svc.cols <- c(1, 2) +p.svc <- length(svc.cols) +phi <- rep(3 / .7, n.factors * p.svc) +sigma.sq <- rep(2, n.factors * p.svc) +nu <- rep(2, n.factors * p.svc) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', svc.cols = svc.cols, + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.cov.3') +det.covs <- list(det.cov.1 = X.p[, , 2], + occ.cov.1 = X[, 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + occ.cov.3 +det.formula <- ~ occ.cov.1 + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + svc.cols = svc.cols, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + svc.cols = svc.cols, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + svc.cols = svc.cols, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- X.0 + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.cov.3') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(1, data.list$det.covs$occ.cov.1) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(X.p.0))) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercept on occurrence ------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45), + sigma.sq.psi = c(1.3)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +svc.cols <- 1 +p.svc <- length(svc.cols) +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ 1 + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + svc.cols = svc.cols, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + svc.cols = svc.cols, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + svc.cols = svc.cols, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + svc.cols = svc.cols, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + svc.cols = svc.cols, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + svc.cols = svc.cols, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts on occurrence -------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(45, 20), + sigma.sq.psi = c(1.3, 3.4)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +svc.cols <- c(1) +p.svc <- length(svc.cols) +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + svc.cols = svc.cols, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + svc.cols = svc.cols, + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + svc.cols = svc.cols, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence REs + covariates --------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.2, -1.9) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20, 10), + sigma.sq.psi = c(1.3, 3.4)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +svc.cols = c(1, 2) +p.svc <- length(svc.cols) +phi <- rep(3 / .7, n.factors * p.svc) +sigma.sq <- rep(2, n.factors * p.svc) +nu <- rep(2, n.factors * p.svc) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', svc.cols = svc.cols, + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + svc.cols = svc.cols, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + svc.cols = svc.cols, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + svc.cols = svc.cols, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + svc.cols = svc.cols, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + svc.cols = svc.cols, + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Occurrence REs + covariates in everything ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.2, -1.9) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, 1.2) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20, 10), + sigma.sq.psi = c(1.3, 3.4)) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +svc.cols <- c(1, 2) +p.svc <- length(svc.cols) +phi <- rep(3 / .7, n.factors * p.svc) +sigma.sq <- rep(2, n.factors * p.svc) +nu <- rep(2, n.factors * p.svc) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', svc.cols = svc.cols, + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ det.cov.1 + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + svc.cols = svc.cols, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + svc.cols = svc.cols, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + svc.cols = svc.cols, + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercept on detection ------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50), + sigma.sq.p = c(2.50)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, 1], dat$X.p.re[, 1, 1]) + colnames(X.p.0) <- c('intercept', 'det.factor.1') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Multiple random intercepts on detection --------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, 1], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Detection random effects with covariates -------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0, 0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Detection random effects with covariates on all ------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.5, 0.3) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 0.5, 3.3) +# Detection +alpha.mean <- c(0, 0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +svc.cols <- c(1, 2, 3) +p.svc <- length(svc.cols) +phi <- rep(3 / .7, n.factors * p.svc) +sigma.sq <- rep(2, n.factors * p.svc) +nu <- rep(2, n.factors * p.svc) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', svc.cols = svc.cols, + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + svc.cols = svc.cols, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + svc.cols = svc.cols, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + svc.cols = svc.cols, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + svc.cols = svc.cols, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercepts on both ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6) +# Detection +alpha.mean <- c(0) +tau.sq.alpha <- c(1) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Random intercepts on both with covariates ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 1.2, -0.5) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 2.4, 0.3) +# Detection +alpha.mean <- c(0, 0.5) +tau.sq.alpha <- c(1, 3.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +svc.cols <- c(1, 2) +occ.formula <- ~ occ.cov.1 + occ.cov.2 + (1 | occ.factor.1) +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + n.factors = 3, + accept.rate = 0.43, + svc.cols = svc.cols, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + n.factors = 3, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + svc.cols = svc.cols, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + svc.cols = svc.cols, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + svc.cols = svc.cols, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + svc.cols = svc.cols, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + svc.cols = svc.cols, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:2]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, max(n.rep))) +}) + +# Third dimension of y != max(n.rep) -------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep<- sample(2:4, size = J, replace = TRUE) +n.rep.max <- 7 +N <- 6 +# Community-level covariate effects +# Occurrence +beta.mean <- c(0.2, 0.5, 1.2) +p.occ <- length(beta.mean) +tau.sq.beta <- c(0.6, 1.5, 2.3) +# Detection +alpha.mean <- c(0, -0.5) +tau.sq.alpha <- c(1, 2.3) +p.det <- length(alpha.mean) +# Random effects +psi.RE <- list() +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +alpha.true <- alpha +n.factors <- 3 +phi <- rep(3 / .7, n.factors) +sigma.sq <- rep(2, n.factors) +nu <- rep(2, n.factors) + +dat <- simMsOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, N = N, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, nu = nu, cov.model = 'matern', + factor.model = TRUE, n.factors = n.factors, n.rep.max = n.rep.max) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + z = apply(y, c(1, 2), max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 0.25) + +batch.length <- 25 +n.batch <- 10 +n.report <- 100 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ det.cov.1 + +out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# To make sure it worked -------------- +test_that("out is of class svcMsPGOcc", { + expect_s3_class(out, "svcMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +# Check default values ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") + + out <- svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcMsPGOcc") +}) + +test_that("verbose prints to the screen", { + + expect_output(svcMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + n.factors = 3, + n.omp.threads = 1, + verbose = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +test_that("fitted works for svcMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) + expect_equal(class(fitted.out$y.rep.samples), "array") + expect_equal(class(fitted.out$p.samples), "array") + expect_equal(dim(fitted.out$y.rep.samples), dim(fitted.out$p.samples)) +}) + +test_that("predict works for svcMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(n.post.samples, N, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(n.post.samples, N, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J)) +}) + + +test_that("posterior predictive checks work for msPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.rep.max)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.rep.max)) +}) + diff --git a/tests/testthat/test-svcPGBinom-NNGP.R b/tests/testthat/test-svcPGBinom-NNGP.R new file mode 100644 index 0000000..f50ab3a --- /dev/null +++ b/tests/testthat/test-svcPGBinom-NNGP.R @@ -0,0 +1,1130 @@ +# Test svcPGBinom.R --------------------------------------------------------- +# NNGP -------------------------------------------------------------------- +skip_on_cran() + +# Intercept only ---------------------------------------------------------- +set.seed(320) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +# weights <- sample(2:4, J, replace = TRUE) +weights <- rep(2, J) +beta <- c(0.3) +p.occ <- length(beta) +psi.RE <- list() +svc.cols <- 1 +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simBinom(J.x = J.x, J.y = J.y, weights = weights, beta = beta, + psi.RE = psi.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +weights.0 <- weights[pred.indx] +weights.fit <- weights[-pred.indx] + +data.list <- list(y = y, coords = coords, weights = weights.fit) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + nu.unif = list(a = 0.5, b = 2.5)) +# Starting values +inits.list <- list(beta = 0, fix = TRUE) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +formula <- ~ 1 + +out <- svcPGBinom(formula = formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGBinom", { + expect_s3_class(out, "svcPGBinom") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- svcPGBinom(formula = formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + n.omp.threads = 1, + verbose = FALSE)) +}) +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") +}) + +test_that("all correlation functions work", { + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") + + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") + + + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGBinom", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGBinom", { + fitted.out <- fitted(out) + expect_equal(length(dim(fitted.out)), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGBinom", { + pred.out <- predict(out, X.0, coords.0, weights.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$y.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) + +# Occurrence covariate only ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +# weights <- sample(2:4, J, replace = TRUE) +weights <- rep(2, J) +beta <- c(0.3, 0.5) +p.occ <- length(beta) +psi.RE <- list() +svc.cols <- c(1, 2) +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 /.9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 2) +nu <- runif(p.svc, 1, 2) +dat <- simBinom(J.x = J.x, J.y = J.y, weights = weights, beta = beta, + psi.RE = psi.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +weights.0 <- weights[pred.indx] +weights.fit <- weights[-pred.indx] + +covs <- cbind(X) +colnames(covs) <- c('int', 'cov.1') +data.list <- list(y = y, coords = coords, weights = weights.fit, covs = covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + nu.unif = list(a = 0.5, b = 2.5)) +# Starting values +inits.list <- list(beta = 0, fix = TRUE) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +formula <- ~ cov.1 + +out <- svcPGBinom(formula = formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGBinom", { + expect_s3_class(out, "svcPGBinom") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") +}) + +test_that("all correlation functions work", { + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") + + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") + + + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGBinom", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGBinom", { + fitted.out <- fitted(out) + expect_equal(length(dim(fitted.out)), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGBinom", { + pred.out <- predict(out, X.0, coords.0, weights.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$y.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$covs[3, ] <- NA + expect_error(svcPGBinom(formula = formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + svc.cols = svc.cols, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Interactions ------------------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +# weights <- sample(2:4, J, replace = TRUE) +weights <- rep(2, J) +beta <- c(0.3, 0.5, -0.5) +p.occ <- length(beta) +psi.RE <- list() +svc.cols <- c(1, 2) +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 /.9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 2) +nu <- runif(p.svc, 1, 2) +dat <- simBinom(J.x = J.x, J.y = J.y, weights = weights, beta = beta, + psi.RE = psi.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +weights.0 <- weights[pred.indx] +weights.fit <- weights[-pred.indx] + +covs <- cbind(X) +colnames(covs) <- c('int', 'cov.1', 'cov.2') +data.list <- list(y = y, coords = coords, weights = weights.fit, covs = covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + nu.unif = list(a = 0.5, b = 2.5)) +# Starting values +inits.list <- list(beta = 0, fix = TRUE) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +formula <- ~ cov.1 * cov.2 + +out <- svcPGBinom(formula = formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGBinom", { + expect_s3_class(out, "svcPGBinom") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") +}) + +test_that("all correlation functions work", { + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") + + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") + + + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGBinom", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGBinom", { + fitted.out <- fitted(out) + expect_equal(length(dim(fitted.out)), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGBinom", { + X.0 <- cbind(X.0, X.0[, 2] * X.0[, 3]) + pred.out <- predict(out, X.0, coords.0, weights.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$y.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$covs[3, ] <- NA + expect_error(svcPGBinom(formula = formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + svc.cols = svc.cols, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Random intercept on occurrence ------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +weights <- sample(1:4, J, replace = TRUE) +# weights <- rep(2, J) +beta <- c(0.3) +p.occ <- length(beta) +psi.RE <- list(levels = c(25), + sigma.sq.psi = c(1.3)) +svc.cols <- c(1) +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 /.9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 2) +nu <- runif(p.svc, 1, 2) +dat <- simBinom(J.x = J.x, J.y = J.y, weights = weights, beta = beta, + psi.RE = psi.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +weights.0 <- weights[pred.indx] +weights.fit <- weights[-pred.indx] + +covs <- cbind(X, X.re) +colnames(covs) <- c('int', 'factor.1') +data.list <- list(y = y, coords = coords, weights = weights.fit, covs = covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + nu.unif = list(a = 0.5, b = 2.5)) +# Starting values +inits.list <- list(beta = 0, fix = TRUE) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +formula <- ~ (1 | factor.1) + +out <- svcPGBinom(formula = formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGBinom", { + expect_s3_class(out, "svcPGBinom") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$psiRE, TRUE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") +}) + +test_that("all correlation functions work", { + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") + + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") + + + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGBinom", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGBinom", { + fitted.out <- fitted(out) + expect_equal(length(dim(fitted.out)), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGBinom", { + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('(Intercept)', 'factor.1') + pred.out <- predict(out, X.0, coords.0, weights.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$y.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$covs[3, ] <- NA + expect_error(svcPGBinom(formula = formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + svc.cols = svc.cols, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Multiple random intercepts + covaraites --------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +weights <- sample(1:4, J, replace = TRUE) +# weights <- rep(2, J) +beta <- c(0.3, 0.3, -0.5) +p.occ <- length(beta) +psi.RE <- list(levels = c(25, 10), + sigma.sq.psi = c(1.3, 0.3)) +svc.cols <- c(1, 3) +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 /.9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 2) +nu <- runif(p.svc, 1, 2) +dat <- simBinom(J.x = J.x, J.y = J.y, weights = weights, beta = beta, + psi.RE = psi.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +weights.0 <- weights[pred.indx] +weights.fit <- weights[-pred.indx] + +covs <- cbind(X, X.re) +colnames(covs) <- c('int', 'cov.1', 'cov.2', 'factor.1', 'factor.2') +data.list <- list(y = y, coords = coords, weights = weights.fit, covs = covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + nu.unif = list(a = 0.5, b = 2.5)) +# Starting values +inits.list <- list(beta = 0, fix = TRUE) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +formula <- ~ cov.1 + cov.2 + (1 | factor.1) + (1 | factor.2) + +out <- svcPGBinom(formula = formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGBinom", { + expect_s3_class(out, "svcPGBinom") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are correct", { + expect_equal(out$psiRE, TRUE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") +}) + +test_that("all correlation functions work", { + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") + + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") + + + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGBinom", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGBinom", { + fitted.out <- fitted(out) + expect_equal(length(dim(fitted.out)), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGBinom", { + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('(Intercept)', 'cov.1', 'cov.2', 'factor.1', 'factor.2') + pred.out <- predict(out, X.0, coords.0, weights.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$y.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$covs[3, ] <- NA + expect_error(svcPGBinom(formula = formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + svc.cols = svc.cols, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Uniform sigma sq -------------------------------------------------------- +test_that("svcPGBinom works with uniform prior on sigma.sq", { + prior.list <- list(sigma.sq.unif = list(0, 5), + nu.unif = list(0.1, 4)) + tuning.list <- list(phi = 0.5, nu = 0.6, sigma.sq = 0.7) + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + priors = prior.list, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") + out <- svcPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = prior.list, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGBinom") +}) diff --git a/tests/testthat/test-svcPGOcc-NNGP.R b/tests/testthat/test-svcPGOcc-NNGP.R new file mode 100644 index 0000000..0de5cc6 --- /dev/null +++ b/tests/testthat/test-svcPGOcc-NNGP.R @@ -0,0 +1,5853 @@ +# Test svcPGOcc.R --------------------------------------------------------- +# NNGP -------------------------------------------------------------------- +skip_on_cran() + +# Intercept only ---------------------------------------------------------- +set.seed(348) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +svc.cols <- 1 +phi <- 3 / .7 +sigma.sq <- 2 +nu <- 2 +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +data.list <- list(y = y, coords = coords) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(a = 0.5, b = 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE), fix = TRUE) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ 1 + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + svc.cols = svc.cols, + n.omp.threads = 1, + verbose = FALSE)) +}) +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Occurrence covariate only ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.9, 1.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +svc.cols <- c(1, 2) +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0.1, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ 1 + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + svc.cols = svc.cols, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + svc.cols = svc.cols, + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + svc.cols = svc.cols, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(svcPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[1, 1] <- NA + # out <- svcPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1) + # expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- matrix(1, nrow = J.str, ncol = p.det) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Detection covariate only ------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.4) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +svc.cols <- 1 +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0.1, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, + det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(a = 0.5, b = 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs[3, ] <- NA +# expect_error(svcPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 500, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Covariates on both ------------------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.8) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.4) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +svc.cols <- c(1, 2) +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, + det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + svc.cols = svc.cols, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + svc.cols = svc.cols, + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + svc.cols = svc.cols, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Interactions on both ---------------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.8, 1.2) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.4) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +svc.cols <- c(1, 2) +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.cov.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, + det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 * occ.cov.2 +det.formula <- ~ det.cov.1 * det.cov.2 +svc.cols <- c(1:4) + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + svc.cols = svc.cols, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + svc.cols = svc.cols, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + X.0 <- cbind(X.0, X.0[, 2] * X.0[, 3]) + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + X.p.0 <- cbind(X.p.0, X.p.0[, 2] * X.p.0[, 3]) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Site covariate on detection --------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.8) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.4) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +svc.cols <- c(1, 2) +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3], + occ.cov.1 = X[, 2]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, + det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 +det.formula <- ~ occ.cov.1 + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs[3, ] <- NA +# expect_error(svcPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 500, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[3]][1] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(1, dat$X[, 2]) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Random intercept on occurrence ------------------------------------------ +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list(levels = c(25), + sigma.sq.psi = c(1.3)) +p.RE <- list() +svc.cols <- 1 +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 10 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ 1 + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(svcPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[1, 1] <- NA + # out <- svcPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1) + # expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + X.0 <- cbind(X.0, X.re.0) + colnames(X.0) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- matrix(dat$X.p[, 1, ], ncol = 1) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Multiple random intercepts on occurrence -------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list(levels = c(10, 12), + sigma.sq.psi = c(0.2, 3.5)) +p.RE <- list() +svc.cols <- 1 +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(svcPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[1, 1] <- NA + # out <- svcPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1) + # expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + X.0.full <- cbind(X.0, X.re.0) + colnames(X.0.full) <- c('int', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- matrix(dat$X.p[, 1, ], ncol = 1) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Occurrence REs + covariates --------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.5) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list(levels = c(20, 15), + sigma.sq.psi = c(0.2, 3.5)) +p.RE <- list() +svc.cols <- c(1, 2) +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') +data.list <- list(y = y, coords = coords, occ.covs = occ.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + svc.cols = svc.cols, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + svc.cols = svc.cols, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + svc.cols = svc.cols, + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs[[1]][1] <- NA + # expect_error(svcPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$y[1, 1] <- NA + # out <- svcPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 500, + # n.chains = 1) + # expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + X.0.full <- cbind(X.0, X.re.0) + colnames(X.0.full) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- matrix(dat$X.p[, 1, ], ncol = 1) + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Occurrence REs + covariates in everything ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.5) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.5) +p.det <- length(alpha) +psi.RE <- list(levels = c(20, 15), + sigma.sq.psi = c(0.2, 3.5)) +p.RE <- list() +svc.cols <- c(1, 2) +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + # data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + svc.cols = svc.cols, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + svc.cols = svc.cols, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + svc.cols = svc.cols, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + svc.cols = svc.cols, + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + svc.cols = svc.cols, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + svc.cols = svc.cols, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + svc.cols = svc.cols, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + X.0.full <- cbind(X.0, X.re.0) + colnames(X.0.full) <- c('int', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Random intercept on detection ------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list(levels = c(50), + sigma.sq.p = c(2.50)) +svc.cols <- 1 +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + X.0.full <- cbind(X.0) + colnames(X.0.full) <- c('int') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1]) + colnames(X.p.0) <- c('intercept', 'det.factor.1') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Multiple random intercepts on detection --------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list(levels = c(50, 25, 30), + sigma.sq.p = c(2.50, 1.2, 0.3)) +svc.cols <- 1 +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs[3, ] <- NA +# expect_error(svcPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 500, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + X.0.full <- cbind(X.0) + colnames(X.0.full) <- c('int') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2', 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Multiple random intercepts with covariates on detection ----------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5, 0.3) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list(levels = c(50, 25, 30), + sigma.sq.p = c(2.50, 1.2, 0.3)) +svc.cols <- 1 +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + det.cov.1 + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs[3, ] <- NA +# expect_error(svcPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 500, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + X.0.full <- cbind(X.0) + colnames(X.0.full) <- c('int') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2', 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Multiple random intercepts with covariates on both ---------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.4) +p.occ <- length(beta) +alpha <- c(-0.5, 0.3) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list(levels = c(50, 25, 30), + sigma.sq.p = c(2.50, 1.2, 0.3)) +svc.cols <- c(1, 2) +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X) +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + det.cov.1 + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + svc.cols = svc.cols, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + svc.cols = svc.cols, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + svc.cols = svc.cols, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + svc.cols = svc.cols, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + X.0.full <- cbind(X.0) + colnames(X.0.full) <- c('int', 'occ.cov.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.factor.1', 'det.factor.2', 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Random intercepts on both ----------------------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3) +p.occ <- length(beta) +alpha <- c(-0.5) +p.det <- length(alpha) +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 25, 30), + sigma.sq.p = c(2.50, 1.2, 0.3)) +svc.cols <- 1 +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.factor.1') +det.covs <- list(det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + X.0.full <- cbind(X.0, X.re.0) + colnames(X.0.full) <- c('int', 'occ.factor.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.factor.1', 'det.factor.2', 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Random intercepts on both with covariates ------------------------------- +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +beta <- c(0.3, 0.5) +p.occ <- length(beta) +alpha <- c(-0.5, -1.2, 0.9) +p.det <- length(alpha) +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 25, 30), + sigma.sq.p = c(2.50, 1.2, 0.3)) +svc.cols <- c(1, 2) +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , drop = FALSE] + 42 +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , drop = FALSE] + 42 +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] + +occ.covs <- cbind(X, X.re) +colnames(occ.covs) <- c('int', 'occ.cov.1', 'occ.factor.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3], + det.factor.1 = X.p.re[, , 1], + det.factor.2 = X.p.re[, , 2], + det.factor.3 = X.p.re[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) + occ.cov.1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + (1 | det.factor.3) + det.cov.1 + det.cov.2 + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs <- as.data.frame(data.list$occ.covs) + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + svc.cols = svc.cols, + priors = prior.list, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 400, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + svc.cols = svc.cols, + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + svc.cols = svc.cols, + priors = prior.list, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + svc.cols = svc.cols, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + X.0.full <- cbind(X.0, X.re.0) + colnames(X.0.full) <- c('int', 'occ.cov.1', 'occ.factor.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full))) +}) +test_that("detection prediction works", { + X.p.0 <- cbind(dat$X.p[, 1, ], dat$X.p.re[, 1, 1:3]) + colnames(X.p.0) <- c('intercept', 'det.cov.1', 'det.cov.2', + 'det.factor.1', 'det.factor.2', 'det.factor.3') + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, max(n.rep))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, max(n.rep))) +}) + +# Fixed sigma sq ---------------------------------------------------- +test_that("svcPGOcc works with fixed sigma.sq", { + prior.list <- list(sigma.sq.ig = 'fixed') + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + priors = prior.list, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + expect_equal(length(unique(out$theta.samples[, 1])), 1) +}) + +# Uniform sigma sq -------------------------------------------------------- +test_that("svcPGOcc works with uniform prior on sigma.sq", { + prior.list <- list(sigma.sq.unif = list(0, 5), + nu.unif = list(0.1, 4)) + tuning.list <- list(phi = 0.5, nu = 0.6, sigma.sq = 0.7) + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + priors = prior.list, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + priors = prior.list, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +# Thir dimension of y != max(n.rep) +J.x <- 8 +J.y <- 8 +J <- J.x * J.y +n.rep <- sample(2:4, J, replace = TRUE) +n.rep.max <- 7 +beta <- c(0.3, 0.8) +p.occ <- length(beta) +alpha <- c(-0.5, 1.2, -0.4) +p.det <- length(alpha) +psi.RE <- list() +p.RE <- list() +svc.cols <- c(1, 2) +p.svc <- length(svc.cols) +phi <- runif(p.svc, 3 / .9, 3 / .1) +sigma.sq <- runif(p.svc, 0.1, 0.9) +nu <- runif(p.svc, 0, 2) +dat <- simOcc(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols, n.rep.max = n.rep.max) +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, , drop = FALSE]) +# Prediction covariates +X.0 <- dat$X[pred.indx, , drop = FALSE] +coords.0 <- as.matrix(dat$coords[pred.indx, , drop = FALSE]) +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , drop = FALSE] + +occ.covs <- X +colnames(occ.covs) <- c('int', 'occ.cov.1') +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, + det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0, z = apply(y, 1, max, na.rm = TRUE)) +# Tuning +tuning.list <- list(phi = 1, nu = 1) + +batch.length <- 25 +n.batch <- 40 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 500, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcPGOcc", { + expect_s3_class(out, "svcPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + svc.cols = svc.cols, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") + + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "matern", + svc.cols = svc.cols, + priors = list(nu.unif = list(0.5, 2)), + tuning = list(phi = 0.5, nu = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs[3, ] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- 1 + tmp.data$det.covs[[1]][1] <- NA + expect_error(svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1] <- NA + out <- svcPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + tuning = tuning.list, + svc.cols = svc.cols, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 500, + n.chains = 1) + expect_s3_class(out, "svcPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcPGOcc", { + pred.out <- predict(out, X.0, coords.0, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0))) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, 1, ] + pred.out <- predict(out, X.p.0, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcPGOcc", { + n.post.samples <- out$n.post * out$n.chains + J.fit <- nrow(X) + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.rep.max)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(length(ppc.out$fit.y), n.post.samples) + expect_equal(length(ppc.out$fit.y.rep), n.post.samples) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.rep.max)) +}) + +# Test residuals ---------------------- +test_that("residuals works", { + out.resids <- residuals(out, n.post.samples = 10) + expect_type(out.resids, 'list') + expect_equal(length(out.resids), 2) +}) + diff --git a/tests/testthat/test-svcTMsPGOcc.R b/tests/testthat/test-svcTMsPGOcc.R new file mode 100644 index 0000000..04aa086 --- /dev/null +++ b/tests/testthat/test-svcTMsPGOcc.R @@ -0,0 +1,2248 @@ +# Test svcTMsPGOcc.R --------------------------------------------------------- + +skip_on_cran() + +# Intercept Only ---------------------------------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4) +tau.sq.beta <- c(1) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1) +tau.sq.alpha <- c(0.5) +p.det <- length(alpha.mean) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +ar1 <- TRUE +sp <- TRUE +svc.cols <- c(1) +p.svc <- length(svc.cols) +n.factors <- 2 +phi <- runif(p.svc * n.factors, 3 / .9, 3 / .3) +factor.model <- TRUE +sigma.sq.t <- runif(N, 0.1, 2) +rho <- runif(N, 0.2, 1) +cov.model <- 'exponential' +range.probs <- runif(N, 0.5, 1) + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho, sp = sp, + svc.cols = svc.cols, n.factors = n.factors, phi = phi, + cov.model = cov.model) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- dat$coords[-pred.indx, ] +coords.0 <- dat$coords[pred.indx, ] +range.ind <- dat$range.ind[, -pred.indx] +range.ind.0 <- dat$range.ind[, pred.indx] + +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + phi.unif = list(a = 3 / 1, 3 / .1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ 1 +det.formula <- ~ 1 + +out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.neighbors = 5, + NNGP = TRUE, + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTMsPGOcc", { + expect_s3_class(out, "svcTMsPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE)) +}) +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y[, -pred.indx, , ]) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + n.factors = n.factors, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "svcTMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = 1, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +test_that("all correlation functions work", { + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") + + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") + + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") +}) + + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTMsPGOcc", { + pred.out <- predict(out, X.0, coords.0 = coords.0, t.cols = 1:n.time.max, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- array(X.p.0[, , 1, ], dim = c(nrow(X.p.0), 1, p.det)) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(coords.0), 1)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcTMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Occurrence covariate only ----------------------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4, -0.5) +tau.sq.beta <- c(1, 0.8) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1) +tau.sq.alpha <- c(0.5) +p.det <- length(alpha.mean) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +ar1 <- TRUE +sp <- TRUE +svc.cols <- c(1) +p.svc <- length(svc.cols) +n.factors <- 2 +phi <- runif(p.svc * n.factors, 3 / .9, 3 / .3) +factor.model <- TRUE +sigma.sq.t <- runif(N, 0.1, 2) +rho <- runif(N, 0.2, 1) +cov.model <- 'exponential' +range.probs <- runif(N, 0.5, 1) + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho, sp = sp, + svc.cols = svc.cols, n.factors = n.factors, phi = phi, + cov.model = cov.model) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- dat$coords[-pred.indx, ] +coords.0 <- dat$coords[pred.indx, ] +range.ind <- dat$range.ind[, -pred.indx] +range.ind.0 <- dat$range.ind[, pred.indx] + +occ.covs <- list(occ.cov.1 = X[, , 2]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + phi.unif = list(a = 3 / 1, 3 / .1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ occ.cov.1 +det.formula <- ~ 1 + +out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.neighbors = 5, + NNGP = TRUE, + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTMsPGOcc", { + expect_s3_class(out, "svcTMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y[, -pred.indx, , ]) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + n.factors = n.factors, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "svcTMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = 1, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +test_that("all correlation functions work", { + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") + + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") + + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") +}) + + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTMsPGOcc", { + pred.out <- predict(out, X.0, coords.0 = coords.0, t.cols = 1:n.time.max, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- array(X.p.0[, , 1, ], dim = c(nrow(X.p.0), 1, p.det)) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(coords.0), 1)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcTMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Detection covariate only ------------------------------------------------ +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4) +tau.sq.beta <- c(1) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1, 0.5) +tau.sq.alpha <- c(0.5, 1) +p.det <- length(alpha.mean) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +ar1 <- TRUE +sp <- TRUE +svc.cols <- c(1) +p.svc <- length(svc.cols) +n.factors <- 2 +phi <- runif(p.svc * n.factors, 3 / .9, 3 / .3) +factor.model <- TRUE +sigma.sq.t <- runif(N, 0.1, 2) +rho <- runif(N, 0.2, 1) +cov.model <- 'exponential' +range.probs <- runif(N, 0.5, 1) + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho, sp = sp, + svc.cols = svc.cols, n.factors = n.factors, phi = phi, + cov.model = cov.model) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- dat$coords[-pred.indx, ] +coords.0 <- dat$coords[pred.indx, ] +range.ind <- dat$range.ind[, -pred.indx] +range.ind.0 <- dat$range.ind[, pred.indx] + +occ.covs <- list(int = X[, , 1]) +det.covs <- list(det.cov.1 = X.p[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + phi.unif = list(a = 3 / 1, 3 / .1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + +out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.neighbors = 5, + NNGP = TRUE, + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 1) + +# Test to make sure it worked --------- +test_that("out is of class svcTMsPGOcc", { + expect_s3_class(out, "svcTMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y[, -pred.indx, , ]) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + n.factors = n.factors, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "svcTMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = 1, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +test_that("all correlation functions work", { + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") + + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") + + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") +}) + + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTMsPGOcc", { + pred.out <- predict(out, X.0, coords.0 = coords.0, t.cols = 1:n.time.max, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- array(X.p.0[, , 1, ], dim = c(nrow(X.p.0), 1, p.det)) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(coords.0), 1)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcTMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Covariates on both ------------------------------------------------------ +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4, -0.9, 0.5, 0.2) +tau.sq.beta <- c(1, 0.5, 1.2, 0.5) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1, 0.5) +tau.sq.alpha <- c(0.5, 1) +p.det <- length(alpha.mean) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +ar1 <- TRUE +sp <- TRUE +svc.cols <- c(1, 3) +p.svc <- length(svc.cols) +n.factors <- 2 +phi <- runif(p.svc * n.factors, 3 / .9, 3 / .3) +factor.model <- TRUE +sigma.sq.t <- runif(N, 0.1, 2) +rho <- runif(N, 0.2, 1) +cov.model <- 'exponential' +range.probs <- runif(N, 0.5, 1) + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho, sp = sp, + svc.cols = svc.cols, n.factors = n.factors, phi = phi, + cov.model = cov.model) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- dat$coords[-pred.indx, ] +coords.0 <- dat$coords[pred.indx, ] +range.ind <- dat$range.ind[, -pred.indx] +range.ind.0 <- dat$range.ind[, pred.indx] + +occ.covs <- list(occ.cov.1 = X[, , 2], + occ.cov.2 = X[, , 3], + occ.cov.3 = X[, , 4]) +det.covs <- list(det.cov.1 = X.p[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + phi.unif = list(a = 3 / 1, 3 / .1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + occ.cov.3 +det.formula <- ~ det.cov.1 + +out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.neighbors = 5, + NNGP = TRUE, + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTMsPGOcc", { + expect_s3_class(out, "svcTMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y[, -pred.indx, , ]) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + n.factors = n.factors, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "svcTMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = 1, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +test_that("all correlation functions work", { + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") + + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") + + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") +}) + + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTMsPGOcc", { + pred.out <- predict(out, X.0, coords.0 = coords.0, t.cols = 1:n.time.max, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- array(X.p.0[, , 1, ], dim = c(nrow(X.p.0), 1, p.det)) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(coords.0), 1)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcTMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +test_that("getSVCSamples works", { + svc.samples <- getSVCSamples(out) + expect_equal(length(svc.samples), p.svc) +}) + +# Interactions on both ---------------------------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4, -0.9, 0.5, 0.2) +tau.sq.beta <- c(1, 0.5, 1.2, 0.5) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1, 0.5, 0.2) +tau.sq.alpha <- c(0.5, 1, 0.3) +p.det <- length(alpha.mean) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +ar1 <- TRUE +sp <- TRUE +svc.cols <- c(1, 3) +p.svc <- length(svc.cols) +n.factors <- 2 +phi <- runif(p.svc * n.factors, 3 / .9, 3 / .3) +factor.model <- TRUE +sigma.sq.t <- runif(N, 0.1, 2) +rho <- runif(N, 0.2, 1) +cov.model <- 'exponential' +range.probs <- runif(N, 0.5, 1) + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho, sp = sp, + svc.cols = svc.cols, n.factors = n.factors, phi = phi, + cov.model = cov.model) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- dat$coords[-pred.indx, ] +coords.0 <- dat$coords[pred.indx, ] +range.ind <- dat$range.ind[, -pred.indx] +range.ind.0 <- dat$range.ind[, pred.indx] + +occ.covs <- list(occ.cov.1 = X[, , 2], + occ.cov.2 = X[, , 3], + occ.cov.3 = X[, , 4]) +det.covs <- list(det.cov.1 = X.p[, , , 2], + det.cov.2 = X.p[, , , 3]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + phi.unif = list(a = 3 / 1, 3 / .1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ occ.cov.1 + occ.cov.2 * occ.cov.3 +det.formula <- ~ det.cov.1 * det.cov.2 + +out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.neighbors = 5, + NNGP = TRUE, + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTMsPGOcc", { + expect_s3_class(out, "svcTMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y[, -pred.indx, , ]) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + n.factors = n.factors, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "svcTMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = 1, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +test_that("all correlation functions work", { + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") + + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") + + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTMsPGOcc", { + X.0 <- abind(X.0, X.0[, , 3] * X.0[, , 4], along = 3) + dimnames(X.0)[[3]] <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.cov.3', + 'occ.cov.2:occ.cov.3') + pred.out <- predict(out, X.0, coords.0 = coords.0, t.cols = 1:n.time.max, + verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, , 1, ] + X.p.0 <- abind(X.p.0, X.p.0[, , 2] * X.p.0[, , 3], along = 3) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcTMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +test_that("getSVCSamples works", { + svc.samples <- getSVCSamples(out) + expect_equal(length(svc.samples), p.svc) +}) + +# Site-level covariate on detection --------------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4, -0.9, 0.5, 0.2) +tau.sq.beta <- c(1, 0.5, 1.2, 0.5) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1, 0.5) +tau.sq.alpha <- c(0.5, 1) +p.det <- length(alpha.mean) +p.RE <- list() +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +ar1 <- TRUE +sp <- TRUE +svc.cols <- c(2, 3) +p.svc <- length(svc.cols) +n.factors <- 2 +phi <- runif(p.svc * n.factors, 3 / .9, 3 / .3) +factor.model <- TRUE +sigma.sq.t <- runif(N, 0.1, 2) +rho <- runif(N, 0.2, 1) +cov.model <- 'exponential' +range.probs <- runif(N, 0.5, 1) + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho, sp = sp, + svc.cols = svc.cols, n.factors = n.factors, phi = phi, + cov.model = cov.model) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- dat$coords[-pred.indx, ] +coords.0 <- dat$coords[pred.indx, ] +range.ind <- dat$range.ind[, -pred.indx] +range.ind.0 <- dat$range.ind[, pred.indx] + +occ.covs <- list(occ.cov.1 = X[, , 2], + occ.cov.2 = X[, , 3], + occ.cov.3 = X[, , 4]) +det.covs <- list(det.cov.1 = X[, , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + phi.unif = list(a = 3 / 1, 3 / .1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + occ.cov.3 +det.formula <- ~ det.cov.1 + +out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.neighbors = 5, + NNGP = TRUE, + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTMsPGOcc", { + expect_s3_class(out, "svcTMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y[, -pred.indx, , ]) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + n.factors = n.factors, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "svcTMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = 1, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +test_that("all correlation functions work", { + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") + + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") + + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") +}) + + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTMsPGOcc", { + pred.out <- predict(out, X.0, coords.0 = coords.0, t.cols = 1:n.time.max, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- X.0[, , 1:2] + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(coords.0), n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcTMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +test_that("getSVCSamples works", { + svc.samples <- getSVCSamples(out) + expect_equal(length(svc.samples), p.svc) +}) + +# Covariates on both ------------------------------------------------------ +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4, -0.9, 0.5, 0.2) +tau.sq.beta <- c(1, 0.5, 1.2, 0.5) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +alpha.mean <- c(-1, 0.5) +tau.sq.alpha <- c(0.5, 1) +p.det <- length(alpha.mean) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} +ar1 <- TRUE +sp <- TRUE +svc.cols <- c(1, 3) +p.svc <- length(svc.cols) +n.factors <- 2 +phi <- runif(p.svc * n.factors, 3 / .9, 3 / .3) +factor.model <- TRUE +sigma.sq.t <- runif(N, 0.1, 2) +rho <- runif(N, 0.2, 1) +cov.model <- 'exponential' +range.probs <- runif(N, 0.5, 1) + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho, sp = sp, + svc.cols = svc.cols, n.factors = n.factors, phi = phi, + cov.model = cov.model) + +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[, -pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- dat$coords[-pred.indx, ] +coords.0 <- dat$coords[pred.indx, ] +range.ind <- dat$range.ind[, -pred.indx] +range.ind.0 <- dat$range.ind[, pred.indx] + +occ.covs <- list(occ.cov.1 = X[, , 2], + occ.cov.2 = X[, , 3], + occ.cov.3 = X[, , 4], + occ.factor.1 = X.re[, , 1]) +det.covs <- list(det.cov.1 = X.p[, , , 2], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs, coords = coords) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + phi.unif = list(a = 3 / 1, 3 / .1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ occ.cov.1 + occ.cov.2 + occ.cov.3 + (1 | occ.factor.1) +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.neighbors = 5, + NNGP = TRUE, + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTMsPGOcc", { + expect_s3_class(out, "svcTMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = n.factors, + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 0, + n.thin = 1, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 0, + n.thin = 1, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y[, -pred.indx, , ]) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + n.factors = n.factors, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "svcTMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1, phi = 0.5), + n.factors = 1, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +test_that("all correlation functions work", { + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "gaussian", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") + + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "spherical", + tuning = list(phi = 0.3), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") + + out <- svcTMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + svc.cols = svc.cols, + batch.length = batch.length, + accept.rate = 0.43, + priors = list(nu.unif = list(0.4, 3)), + cov.model = "matern", + tuning = list(phi = 0.3, nu = 0.2), + n.factors = 3, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 1, + n.chains = 1) + expect_s3_class(out, "svcTMsPGOcc") +}) + + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTMsPGOcc", { + X.0 <- abind(X.0, X.re.0, along = 3) + dimnames(X.0)[[3]] <- c('(Intercept)', 'occ.cov.1', 'occ.cov.2', 'occ.cov.3', 'occ.factor.1') + pred.out <- predict(out, X.0, coords.0 = coords.0, t.cols = 1:n.time.max, verbose = FALSE) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, nrow(X.0), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind(X.p.0[, , 1, ], X.p.re.0[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', + 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, nrow(coords.0), n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for svcTMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, nrow(X), n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, nrow(X), n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +test_that("getSVCSamples works", { + svc.samples <- getSVCSamples(out) + expect_equal(length(svc.samples), p.svc) +}) diff --git a/tests/testthat/test-svcTPGBinom-NNGP.R b/tests/testthat/test-svcTPGBinom-NNGP.R new file mode 100644 index 0000000..5187015 --- /dev/null +++ b/tests/testthat/test-svcTPGBinom-NNGP.R @@ -0,0 +1,1235 @@ +# Test svcTPGBinom.R --------------------------------------------------------- +# NNGP -------------------------------------------------------------------- +skip_on_cran() + +# Intercept only ---------------------------------------------------------- +set.seed(150) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +weights <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + weights[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +svc.cols <- 1 +psi.RE <- list() +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTBinom(J.x = J.x, J.y = J.y, n.time = n.time, weights = weights, + beta = beta, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] +weights.0 <- weights[pred.indx, ] +weights.fit <- weights[-pred.indx, ] + +covs <- list(int = X[, , 1]) + +data.list <- list(y = y, coords = coords, covs = covs, weights = weights.fit) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(a = 0.5, b = 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +formula <- ~ 1 + +out <- svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGBinom", { + expect_s3_class(out, "svcTPGBinom") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- svcTPGBinom(formula =formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + n.omp.threads = 1, + verbose = FALSE)) +}) +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGBinom") +}) + +test_that("all correlation functions work", { + out <- svcTPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGBinom") + + out <- svcTPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGBinom") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGBinom", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGBinom", { + fitted.out <- fitted(out) + expect_equal(fitted.out, out$y.rep.samples) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGBinom", { + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1') + X.0.full <- X.0 + pred.out <- predict(out, X.0.full, coords.0, weights.0, verbose = FALSE, t.cols = 1:n.time.max, + weights = weights.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$y.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) + +# Occurrence covariate only ----------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +weights <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + weights[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.8) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +svc.cols <- c(1, 2) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTBinom(J.x = J.x, J.y = J.y, n.time = n.time, weights = weights, + beta = beta, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] +weights.0 <- weights[pred.indx, ] +weights.fit <- weights[-pred.indx, ] + + +covs <- list(int = X[, , 1], + trend = X[, , 2]) + +data.list <- list(y = y, coords = coords, covs = covs, weights = weights.fit) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +formula <- ~ trend + +out <- svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 1, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGBinom", { + expect_s3_class(out, "svcTPGBinom") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGBinom") +}) + +test_that("all correlation functions work", { + out <- svcTPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGBinom") + + out <- svcTPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGBinom") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + ar1 = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$covs$trend[3, ] <- NA + expect_error(svcTPGBinom(formula = formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGBinom", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGBinom", { + fitted.out <- fitted(out) + expect_equal(fitted.out, out$y.rep.samples) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGBinom", { + X.0.full <- X.0 + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max, + weights = weights.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$y.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) + +# Random intercept on occurrence ------------------------------------------ +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +weights <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + weights[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10), + sigma.sq.psi = c(0.8)) +svc.cols = c(1) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTBinom(J.x = J.x, J.y = J.y, n.time = n.time, weights = weights, + beta = beta, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] +weights.0 <- weights[pred.indx, ] +weights.fit <- weights[-pred.indx, ] + +covs <- list(int = X[, , 1], + occ.factor.1 = X.re[, , 1]) + +data.list <- list(y = y, coords = coords, covs = covs, weights = weights.fit) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +formula <- ~ (1 | occ.factor.1) +det.formula <- ~ 1 + +out <- svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGBinom", { + expect_s3_class(out, "svcTPGBinom") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$covs$occ.factor.1 <- factor(data.list$covs$occ.factor.1) + expect_error(out <- svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$covs$occ.factor.1 <- as.character(factor(data.list$covs$occ.factor.1)) + expect_error(out <- svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGBinom") +}) + +test_that("all correlation functions work", { + out <- svcTPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGBinom") + + out <- svcTPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGBinom") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGBinom", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGBinom", { + fitted.out <- fitted(out) + expect_equal(fitted.out, out$y.rep.samples) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGBinom", { + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'occ.factor.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max, + weights = weights.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$y.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) + +# Multiple random intercepts on occurrence -------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +weights <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + weights[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10, 15), + sigma.sq.psi = c(0.8, 0.3)) +svc.cols <- c(1) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTBinom(J.x = J.x, J.y = J.y, n.time = n.time, weights = weights, + beta = beta, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] +weights.0 <- weights[pred.indx, ] +weights.fit <- weights[-pred.indx, ] + +covs <- list(int = X[, , 1], + occ.factor.1 = X.re[, , 1], + occ.factor.2 = X.re[, , 2]) + +data.list <- list(y = y, coords = coords, covs = covs, weights = weights.fit) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +formula <- ~ (1 | occ.factor.1) + (1 | occ.factor.2) + +out <- svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGBinom", { + expect_s3_class(out, "svcTPGBinom") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$covs$occ.factor.1 <- factor(data.list$covs$occ.factor.1) + expect_error(out <- svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$covs$occ.factor.1 <- as.character(factor(data.list$covs$occ.factor.1)) + expect_error(out <- svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGBinom") +}) + +test_that("all correlation functions work", { + out <- svcTPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGBinom") + + out <- svcTPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGBinom") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGBinom", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGBinom", { + fitted.out <- fitted(out) + expect_equal(fitted.out, out$y.rep.samples) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGBinom", { + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max, + weights = weights.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$y.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) + +# Occurrence REs + covariates --------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +weights <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + weights[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.5) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10, 15), + sigma.sq.psi = c(0.8, 0.3)) +svc.cols <- c(1, 2) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTBinom(J.x = J.x, J.y = J.y, n.time = n.time, weights = weights, + beta = beta, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] +weights.0 <- weights[pred.indx, ] +weights.fit <- weights[-pred.indx, ] + +covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.factor.1 = X.re[, , 1], + occ.factor.2 = X.re[, , 2]) + +data.list <- list(y = y, coords = coords, covs = covs, weights = weights.fit) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +inits.list <- list(alpha = 0, beta = 0) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +formula <- ~ trend + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGBinom", { + expect_s3_class(out, "svcTPGBinom") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$covs$occ.factor.1 <- factor(data.list$covs$occ.factor.1) + expect_error(out <- svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$covs$occ.factor.1 <- as.character(factor(data.list$covs$occ.factor.1)) + expect_error(out <- svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGBinom") +}) + +test_that("all correlation functions work", { + out <- svcTPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGBinom") + + out <- svcTPGBinom(formula = formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGBinom") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGBinom(formula = formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + ar1 = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$covs$trend[3, ] <- NA + expect_error(svcTPGBinom(formula = formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGBinom", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGBinom", { + fitted.out <- fitted(out) + expect_equal(fitted.out, out$y.rep.samples) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGBinom", { + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max, + weights = weights.0) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$y.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) diff --git a/tests/testthat/test-svcTPGOcc-NNGP.R b/tests/testthat/test-svcTPGOcc-NNGP.R new file mode 100644 index 0000000..932e112 --- /dev/null +++ b/tests/testthat/test-svcTPGOcc-NNGP.R @@ -0,0 +1,6339 @@ +# Test svcTPGOcc.R --------------------------------------------------------- +# NNGP -------------------------------------------------------------------- +skip_on_cran() + +# Intercept only ---------------------------------------------------------- +set.seed(150) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +svc.cols <- 1 +psi.RE <- list() +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list() +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(a = 0.5, b = 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ 1 + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + svc.cols = svc.cols, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + n.omp.threads = 1, + verbose = FALSE)) +}) +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +# test_that("random effect gives error when non-numeric", { +# data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) +# data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) +# expect_error(out <- svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) +# data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) +# expect_error(out <- svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# }) + +# Check RE levels --------------------- +# test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +# }) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs$trend[3, ] <- NA + # expect_error(svcTPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + # expect_error(svcTPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1') + X.0.full <- X.0 + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + # X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + # dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + X.p.0 <- array(dat$X.p[, , 1, ], dim = c(J, n.time.max, p.det)) + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Occurrence covariate only ----------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.8) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list() +svc.cols <- c(1, 2) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1], + trend = X[, , 2]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ trend +det.formula <- ~ 1 + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 1, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +# test_that("random effect gives error when non-numeric", { +# data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) +# data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) +# expect_error(out <- svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) +# data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) +# expect_error(out <- svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# }) + +# Check RE levels --------------------- +# test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +# }) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + ar1 = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + # expect_error(svcTPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + X.0.full <- X.0 + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)) + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Detection covariate only ------------------------------------------------ +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5, -0.4) +p.det <- length(alpha) +p.RE <- list() +svc.cols <- c(1) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.cov.2 = X.p[, , , 3]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +# test_that("random effect gives error when non-numeric", { +# data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) +# data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) +# expect_error(out <- svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) +# data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) +# expect_error(out <- svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# }) + +# Check RE levels --------------------- +# test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +# }) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "spherical", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs$trend[3, ] <- NA +# expect_error(svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + X.0.full <- X.0 + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, , 1, ] + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Covariates on both ------------------------------------------------------ +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.4) +p.occ <- length(beta) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5, -0.4) +p.det <- length(alpha) +p.RE <- list() +svc.cols = c(1, 2) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1], + occ.cov.1 = X[, , 2]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.cov.2 = X.p[, , , 3]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +# test_that("random effect gives error when non-numeric", { +# data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) +# data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) +# expect_error(out <- svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) +# data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) +# expect_error(out <- svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# }) + +# Check RE levels --------------------- +# test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +# }) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$occ.cov.1[3, ] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + X.0.full <- X.0 + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, , 1, ] + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Interactions on both ---------------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.4, 0.2) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5, -0.4) +p.det <- length(alpha) +p.RE <- list() +svc.cols = c(1, 2, 3) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.cov.1 = X[, , 3]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.cov.2 = X.p[, , , 3]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ trend * occ.cov.1 +det.formula <- ~ det.cov.1 * det.cov.2 + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +# test_that("random effect gives error when non-numeric", { +# data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) +# data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) +# expect_error(out <- svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) +# data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) +# expect_error(out <- svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# }) + +# Check RE levels --------------------- +# test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +# }) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + X.0.full <- abind(X.0, X.0[, , 3, drop = FALSE] * X.0[, , 2, drop = FALSE]) + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, , 1, ] + X.p.0 <- abind(X.p.0, X.p.0[, , 2, drop = FALSE] * X.p.0[, , 3, drop = FALSE]) + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Site covariate on detection --------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5) +p.det <- length(alpha) +p.RE <- list() +svc.cols = c(1, 2) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1], + trend = X[, , 2]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + trend = X[, , 2]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ trend +det.formula <- ~ trend + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +# test_that("random effect gives error when non-numeric", { +# data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) +# data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) +# expect_error(out <- svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) +# data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) +# expect_error(out <- svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# }) + +# Check RE levels --------------------- +# test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +# }) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + ar1 = TRUE, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$trend[1, 1] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + X.0.full <- X.0 + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, , 1, ] + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + + +# Random intercept on occurrence ------------------------------------------ +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10), + sigma.sq.psi = c(0.8)) +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list() +svc.cols = c(1) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1], + occ.factor.1 = X.re[, , 1]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ 1 + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + #data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs$trend[3, ] <- NA + # expect_error(svcTPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + # expect_error(svcTPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'occ.factor.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + # X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + X.p.0 <- array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)) + # dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Multiple random intercepts on occurrence -------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10, 15), + sigma.sq.psi = c(0.8, 0.3)) +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list() +svc.cols <- c(1) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1], + occ.factor.1 = X.re[, , 1], + occ.factor.2 = X.re[, , 2]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + #data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs$trend[3, ] <- NA + # expect_error(svcTPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + # expect_error(svcTPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + # X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + X.p.0 <- array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)) + # dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Occurrence REs + covariates --------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.5) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10, 15), + sigma.sq.psi = c(0.8, 0.3)) +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list() +svc.cols <- c(1, 2) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.factor.1 = X.re[, , 1], + occ.factor.2 = X.re[, , 2]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ trend + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + #data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + ar1 = TRUE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + # expect_error(svcTPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + # X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + X.p.0 <- array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)) + # dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Occurrence REs + covariates on both ------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.5) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10, 15), + sigma.sq.psi = c(0.8, 0.3)) +alpha <- c(-1, 0.5) +p.det <- length(alpha) +p.RE <- list() +svc.cols <- c(1, 2) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.factor.1 = X.re[, , 1], + occ.factor.2 = X.re[, , 2]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ trend + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ det.cov.1 + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + #data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + # data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + ar1 = TRUE, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + # X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + X.p.0 <- dat$X.p[, , 1, ] + # dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Random intercept on detection ------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list(levels = c(20), + sigma.sq.p = c(1)) +svc.cols <- c(1) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.factor.1 = X.p.re[, , , 1]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs$trend[3, ] <- NA +# expect_error(svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.chains = 1)) +# tmp.data <- data.list +# tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA +# expect_error(svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1') + X.0.full <- X.0 + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind::abind(array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)), + dat$X.p.re[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.factor.1') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Multiple random intercepts on detection --------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list(levels = c(20, 15), + sigma.sq.p = c(1, 0.5)) +svc.cols <- c(1) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs$trend[3, ] <- NA +# expect_error(svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.chains = 1)) +# tmp.data <- data.list +# tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA +# expect_error(svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1') + X.0.full <- X.0 + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind::abind(array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)), + dat$X.p.re[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Random detection intercepts + detection covariates ---------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5) +p.det <- length(alpha) +p.RE <- list(levels = c(20, 15), + sigma.sq.p = c(1, 0.5)) +svc.cols <- c(1) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs$trend[3, ] <- NA +# expect_error(svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = 40, +# batch.length = batch.length, +# cov.model = "exponential", +# tuning = tuning.list, +# NNGP = TRUE, +# verbose = FALSE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1') + X.0.full <- X.0 + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Random detection intercepts + covariates -------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.5) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5) +p.det <- length(alpha) +p.RE <- list(levels = c(20, 15), + sigma.sq.p = c(1, 0.5)) +svc.cols <- c(1, 2) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1], + trend = X[, , 2]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ trend +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1') + X.0.full <- X.0 + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Random intercepts on both ----------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10), + sigma.sq.psi = c(0.8)) +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list(levels = c(20), + sigma.sq.p = c(0.4)) +svc.cols <- c(1) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1], + occ.factor.1 = X.re[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.factor.1 = X.p.re[, , , 1]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ (1 | det.factor.1) + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + # tmp.data <- data.list + # tmp.data$occ.covs$trend[3, ] <- NA + # expect_error(svcTPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + # tmp.data <- data.list + # tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + # expect_error(svcTPGOcc(occ.formula = occ.formula, + # det.formula = det.formula, + # data = tmp.data, + # n.batch = 40, + # batch.length = batch.length, + # cov.model = "exponential", + # tuning = tuning.list, + # NNGP = TRUE, + # verbose = FALSE, + # n.neighbors = 5, + # search.type = 'cb', + # n.report = 10, + # n.burn = 100, + # n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'occ.factor.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + # X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + X.p.0 <- abind::abind(array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)), + array(dat$X.p.re[, , 1, ], dim = c(J, n.time.max, 1)), along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.factor.1') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) +# Random intercepts on both with covariates ------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.8) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10), + sigma.sq.psi = c(0.8)) +alpha <- c(-1, 0.5) +p.det <- length(alpha) +p.RE <- list(levels = c(20, 15), + sigma.sq.p = c(1, 0.5)) +svc.cols <- c(1, 2) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.factor.1 = X.re[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ trend + (1 | occ.factor.1) +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + priors = prior.list, + cov.model = "matern", + svc.cols = svc.cols, + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.thin = 2, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "gaussian", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + ar1 = TRUE, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + X.0.full <- abind::abind(X.0, X.re.0, along = 3) + dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Covariates on both ------------------------------------------------------ +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +n.rep.max <- 7 +beta <- c(0.4, 0.4) +p.occ <- length(beta) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5, -0.4) +p.det <- length(alpha) +p.RE <- list() +svc.cols = c(1, 2) +phi <- rep(3 / .7, length(svc.cols)) +sigma.sq <- rep(2, length(svc.cols)) +nu <- rep(2, length(svc.cols)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, sp = TRUE, sigma.sq = sigma.sq, + phi = phi, cov.model = 'matern', nu = nu, svc.cols = svc.cols, n.rep.max = n.rep.max) + +# Subset data for prediction +pred.indx <- sample(1:J, round(J * .25), replace = FALSE) +y <- dat$y[-pred.indx, , , drop = FALSE] +# Occupancy covariates +X <- dat$X[-pred.indx, , , drop = FALSE] +# X.re <- dat$X.re[-pred.indx, , , drop = FALSE] +# Prediction covariates +X.0 <- dat$X[pred.indx, , , drop = FALSE] +# X.re.0 <- dat$X.re[pred.indx, , , drop = FALSE] +# Detection covariates +X.p <- dat$X.p[-pred.indx, , , , drop = FALSE] +# X.p.re <- dat$X.p.re[-pred.indx, , , , drop = FALSE] +X.p.0 <- dat$X.p[pred.indx, , , , drop = FALSE] +# X.p.re.0 <- dat$X.p.re[pred.indx, , , , drop = FALSE] +coords <- as.matrix(dat$coords[-pred.indx, ]) +coords.0 <- as.matrix(dat$coords[pred.indx, ]) +psi.0 <- dat$psi[pred.indx, ] +w.0 <- dat$w[pred.indx, ] + +occ.covs <- list(int = X[, , 1], + occ.cov.1 = X[, , 2]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.cov.2 = X.p[, , , 3]) + +data.list <- list(y = y, coords = coords, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72), + nu.unif = list(0.5, 2.5)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) +# Tuning +tuning.list <- list(phi = 1, nu = 1, rho = 1) + +batch.length <- 25 +n.batch <- 10 +n.report <- 10 +n.samples <- batch.length * n.batch +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + batch.length = batch.length, + n.batch = n.batch, + priors = prior.list, + accept.rate = 0.43, + svc.cols = svc.cols, + cov.model = "matern", + tuning = tuning.list, + n.omp.threads = 1, + verbose = FALSE, + NNGP = TRUE, + n.neighbors = 10, + n.report = n.report, + n.burn = 100, + n.chains = 2, + n.thin = 2, + k.fold = 2, + k.fold.threads = 2) + +# Test to make sure it worked --------- +test_that("out is of class svcTPGOcc", { + expect_s3_class(out, "svcTPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE error ---------------------- +# test_that("random effect gives error when non-numeric", { +# data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) +# data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) +# expect_error(out <- svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) +# data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) +# expect_error(out <- svcTPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = data.list, +# inits = inits.list, +# n.batch = n.batch, +# batch.length = batch.length, +# accept.rate = 0.43, +# priors = prior.list, +# cov.model = "matern", +# tuning = tuning.list, +# n.omp.threads = 1, +# verbose = FALSE, +# NNGP = TRUE, +# n.neighbors = 5, +# search.type = 'cb', +# n.report = 10, +# n.burn = 100, +# n.thin = 2, +# n.chains = 1)) +# }) + +# Check RE levels --------------------- +# test_that("random effect levels are correct", { +# expect_equal(sort(unique(unlist(out$p.re.level.names))), +# sort(unique(c(X.p.re)))) +# expect_equal(sort(unique(unlist(out$re.level.names))), +# sort(unique(c(X.re)))) +# }) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, y) +}) + +test_that("default priors and inits work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("all correlation functions work", { + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "gaussian", + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") + + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = 40, + batch.length = batch.length, + cov.model = "spherical", + svc.cols = svc.cols, + tuning = list(phi = 0.5), + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +test_that("verbose prints to the screen", { + expect_output(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + priors = prior.list, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$occ.cov.1[3, ] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + svc.cols = svc.cols, + cov.model = "exponential", + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- svcTPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = 40, + batch.length = batch.length, + cov.model = "exponential", + svc.cols = svc.cols, + tuning = tuning.list, + NNGP = TRUE, + verbose = FALSE, + n.neighbors = 5, + search.type = 'cb', + n.report = 10, + n.burn = 100, + n.chains = 1) + expect_s3_class(out, "svcTPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for svcTPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for svcTPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for svcTPGOcc", { + X.0.full <- X.0 + # X.0.full <- abind::abind(X.0, X.re.0, along = 3) + # dimnames(X.0.full)[[3]] <- c('(Intercept)', 'trend') + pred.out <- predict(out, X.0.full, coords.0, verbose = FALSE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, nrow(X.0.full), n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, , 1, ] + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + J.fit <- nrow(X) + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, n.rep.max)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J.fit, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J.fit, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, n.rep.max)) +}) + diff --git a/tests/testthat/test-tMsPGOcc.R b/tests/testthat/test-tMsPGOcc.R new file mode 100644 index 0000000..e904305 --- /dev/null +++ b/tests/testthat/test-tMsPGOcc.R @@ -0,0 +1,1779 @@ +# Test tMsPGOcc.R --------------------------------------------------------- + +skip_on_cran() + +# Intercept Only ---------------------------------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4) +tau.sq.beta <- c(1) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1) +tau.sq.alpha <- c(0.5) +p.det <- length(alpha.mean) +p.RE <- list() +sp <- FALSE +factor.model <- FALSE +ar1 <- TRUE +sigma.sq.t <- runif(N, 0.1, 5) +rho <- runif(N, 0, 1) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho) +y <- dat$y +X <- dat$X +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ 1 +det.formula <- ~ 1 + +out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class tMsPGOcc", { + expect_s3_class(out, "tMsPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + n.omp.threads = 1, + verbose = FALSE)) +}) +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for tMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tMsPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- array(1, dim = c(J.str, 1, p.det)) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str, 1)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Occurrence covariate only ----------------------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4, 0.5, -0.2) +tau.sq.beta <- c(1, 0.5, 1) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1) +tau.sq.alpha <- c(0.5) +p.det <- length(alpha.mean) +p.RE <- list() +sp <- FALSE +factor.model <- FALSE +ar1 <- TRUE +sigma.sq.t <- runif(N, 0.1, 5) +rho <- runif(N, 0, 1) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho) +y <- dat$y +X <- dat$X +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1], + occ.cov.1 = X[, , 2], + occ.cov.2 = X[, , 3]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ occ.cov.1 + occ.cov.2 +det.formula <- ~ 1 + +out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class tMsPGOcc", { + expect_s3_class(out, "tMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for tMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tMsPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- array(1, dim = c(J.str, 1, p.det)) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str, 1)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Detection covariate only ------------------------------------------------ +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4) +tau.sq.beta <- c(1) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1, 0.2, 0.4) +tau.sq.alpha <- c(0.5, 1, 1.2) +p.det <- length(alpha.mean) +p.RE <- list() +sp <- FALSE +factor.model <- FALSE +ar1 <- TRUE +sigma.sq.t <- runif(N, 0.1, 5) +rho <- runif(N, 0, 1) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho) +y <- dat$y +X <- dat$X +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 1], + det.cov.2 = X.p[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class tMsPGOcc", { + expect_s3_class(out, "tMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for tMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tMsPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, , 1, ] + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Covariates on both ------------------------------------------------------ +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4, 0.3) +tau.sq.beta <- c(1, 0.5) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1, 0.2, 0.4) +tau.sq.alpha <- c(0.5, 1, 1.2) +p.det <- length(alpha.mean) +p.RE <- list() +sp <- FALSE +factor.model <- FALSE +ar1 <- TRUE +sigma.sq.t <- runif(N, 0.1, 5) +rho <- runif(N, 0, 1) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho) +y <- dat$y +X <- dat$X +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1], + occ.cov.1 = X[, , 2]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 1], + det.cov.2 = X.p[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.2 + +out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class tMsPGOcc", { + expect_s3_class(out, "tMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for tMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tMsPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, , 1, ] + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Interactions on both ---------------------------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4, 0.3, -0.3) +tau.sq.beta <- c(1, 0.5, 1.2) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1, 0.2, 0.4) +tau.sq.alpha <- c(0.5, 1, 1.2) +p.det <- length(alpha.mean) +p.RE <- list() +sp <- FALSE +factor.model <- FALSE +ar1 <- TRUE +sigma.sq.t <- runif(N, 0.1, 5) +rho <- runif(N, 0, 1) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho) +y <- dat$y +X <- dat$X +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1], + occ.cov.1 = X[, , 2], + occ.cov.2 = X[, , 3]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 1], + det.cov.2 = X.p[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ occ.cov.1 * occ.cov.2 +det.formula <- ~ det.cov.1 * det.cov.2 + +out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class tMsPGOcc", { + expect_s3_class(out, "tMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for tMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tMsPGOcc", { + X.0 <- dat$X + X.0 <- abind(X.0, X.0[, , 2] * X.0[, , 3], along = 3) + dimnames(X.0)[[3]] <- c('int', 'occ.cov.1', 'occ.cov.2', 'occ.cov.1:occ.cov.2') + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- dat$X.p[, , 1, ] + X.p.0 <- abind(X.p.0, X.p.0[, , 2] * X.p.0[, , 3], along = 3) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Site covariate on detection --------------------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4, 0.5, -0.2) +tau.sq.beta <- c(1, 0.5, 1) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha.mean <- c(-1) +tau.sq.alpha <- c(0.5) +p.det <- length(alpha.mean) +p.RE <- list() +sp <- FALSE +factor.model <- FALSE +ar1 <- TRUE +sigma.sq.t <- runif(N, 0.1, 5) +rho <- runif(N, 0, 1) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho) +y <- dat$y +X <- dat$X +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1], + occ.cov.1 = X[, , 2], + occ.cov.2 = X[, , 3]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X[, , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + +out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class tMsPGOcc", { + expect_s3_class(out, "tMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for tMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tMsPGOcc", { + X.0 <- dat$X[, , 1, drop = FALSE] + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- abind(dat$X[, , 1], dat$X[, , 2], along = 3) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Random intercept on occurrence ------------------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4) +tau.sq.beta <- c(1) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list(levels = c(45), + sigma.sq.psi = c(1.3)) +alpha.mean <- c(-1) +tau.sq.alpha <- c(0.5) +p.det <- length(alpha.mean) +p.RE <- list() +sp <- FALSE +factor.model <- FALSE +ar1 <- TRUE +sigma.sq.t <- runif(N, 0.1, 5) +rho <- runif(N, 0, 1) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho) +y <- dat$y +X <- dat$X +X.re <- dat$X.re +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1], + occ.factor.1 = X.re[, , 1]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ 1 + +out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class tMsPGOcc", { + expect_s3_class(out, "tMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + expect_error(out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + expect_error(out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for tMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tMsPGOcc", { + X.0 <- abind(dat$X, dat$X.re, along = 3) + dimnames(X.0)[[3]] <- c('(Intercept)', 'occ.factor.1') + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- array(1, dim = c(J.str, 1, p.det)) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J.str, 1)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Multiple random intercepts on occurrence -------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +N <- 6 +beta.mean <- c(0.4, 0.3) +tau.sq.beta <- c(1, 0.5) +p.occ <- length(beta.mean) +trend <- FALSE +sp.only <- 0 +psi.RE <- list(levels = c(20), + sigma.sq.psi = c(2.5)) +p.RE <- list(levels = c(50, 10), + sigma.sq.p = c(2.50, 1.5)) +alpha.mean <- c(-1, 0.2, 0.4) +tau.sq.alpha <- c(0.5, 1, 1.2) +p.det <- length(alpha.mean) +sp <- FALSE +factor.model <- FALSE +ar1 <- TRUE +sigma.sq.t <- runif(N, 0.1, 5) +rho <- runif(N, 0, 1) +# Draw species-level effects from community means. +beta <- matrix(NA, nrow = N, ncol = p.occ) +alpha <- matrix(NA, nrow = N, ncol = p.det) +for (i in 1:p.occ) { + beta[, i] <- rnorm(N, beta.mean[i], sqrt(tau.sq.beta[i])) +} +for (i in 1:p.det) { + alpha[, i] <- rnorm(N, alpha.mean[i], sqrt(tau.sq.alpha[i])) +} + +dat <- simTMsOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, N = N, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, factor.model = factor.model, + ar1 = ar1, sigma.sq.t = sigma.sq.t, rho = rho) +y <- dat$y +X <- dat$X +X.p <- dat$X.p +X.re <- dat$X.re +X.p.re <- dat$X.p.re +occ.covs <- list(int = X[, , 1], + occ.cov.1 = X[, , 2], + occ.factor.1 = X.re[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 1], + det.cov.2 = X.p[, , , 2], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.comm.normal = list(mean = 0, var = 2.72), + alpha.comm.normal = list(mean = 0, var = 2.72), + tau.sq.beta.ig = list(a = 0.1, b = 0.1), + tau.sq.alpha.ig = list(a = 0.1, b = 0.1), + rho.unif = list(a = -1, b = 1), + sigma.sq.t.ig = list(a = 2, b = 1)) +# Starting values +z.init <- apply(y, c(1, 2, 3), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha.comm = 0, + beta.comm = 0, + beta = 0, + alpha = 0, + tau.sq.beta = 1, + tau.sq.alpha = 1, + sigma.sq.p = 0.5, + z = z.init) + +n.batch <- 10 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 10 +occ.formula <- ~ occ.cov.1 + (1 | occ.factor.1) +det.formula <- ~ det.cov.1 + det.cov.2 + (1 | det.factor.1) + (1 | det.factor.2) + +out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 100, + n.thin = 2, + n.chains = 2) + +# Test to make sure it worked --------- +test_that("out is of class tMsPGOcc", { + expect_s3_class(out, "tMsPGOcc") +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 0, + n.thin = 1, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 0, + n.thin = 1, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + ar1 = FALSE, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tMsPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tMsPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tMsPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) +test_that("waicOCC works for multiple species", { + # as.vector gets rid of names + waic.out <- waicOcc(out, by.sp = TRUE) + expect_equal(nrow(waic.out), N) +}) + +# Check fitted ------------------------ +test_that("fitted works for tMsPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tMsPGOcc", { + X.0 <- abind(dat$X, dat$X.re, along = 3) + dimnames(X.0)[[3]] <- c('(Intercept)', 'occ.cov.1', 'occ.factor.1') + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.cov.2', + 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, N, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tMsPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, N, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, N, n.time.max, max(n.rep, na.rm = TRUE))) +}) + + diff --git a/tests/testthat/test-tPGOcc.R b/tests/testthat/test-tPGOcc.R new file mode 100644 index 0000000..7369b27 --- /dev/null +++ b/tests/testthat/test-tPGOcc.R @@ -0,0 +1,3957 @@ +# Test tPGOcc.R ----------------------------------------------------------- + +skip_on_cran() + +# Intercept Only ---------------------------------------------------------- +set.seed(100) +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list() +ar1 <- TRUE +rho <- 0.9 +sigma.sq.t <- 2.4 +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, ar1 = TRUE, rho = rho, sigma.sq.t = sigma.sq.t) +y <- dat$y +X <- dat$X +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +out <- tPGOcc(occ.formula = ~ 1, + det.formula = ~ 1, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) +# Check non-integer n.post ------------- +test_that("non-integer n.post", { + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.thin = 13, + n.batch = n.batch, + batch.length = batch.length, + accept.rate = 0.43, + n.omp.threads = 1, + verbose = FALSE)) +}) +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = ~ 1, + det.formula = ~ 1, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = ~ 1, + det.formula = ~ 1, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- array(1, dim = c(J.str, 1, p.det)) + pred.out <- predict(out, X.p.0, t.cols = 1:n.time.max, type = 'detection') + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str, 1)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Occurrence covariate only ----------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.5) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list() +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE) +y <- dat$y +X <- dat$X +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1], + trend = X[, , 2]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ trend +det.formula <- ~ 1 +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- array(1, dim = c(J.str, 1, p.det)) + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str, 1)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Detection covariate only ----------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5) +p.det <- length(alpha) +p.RE <- list() +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE) +y <- dat$y +X <- dat$X +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- dat$X.p[, , 1, ] + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Covariates on both ------------------------------------------------------ +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.6, 0.5) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5, 0.3, -0.4) +p.det <- length(alpha) +p.RE <- list() +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE) +y <- dat$y +X <- dat$X +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.cov.1 = X[, , 3]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.cov.2 = X.p[, , , 3], + det.cov.3 = X.p[, , , 4]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ trend + occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.1 + det.cov.2 + det.cov.3 +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- dat$X.p[, , 1, ] + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Intercations in both ---------------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.6, 0.5) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5, 0.3, -0.4) +p.det <- length(alpha) +p.RE <- list() +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE) +y <- dat$y +X <- dat$X +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.cov.1 = X[, , 3]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.cov.2 = X.p[, , , 3], + det.cov.3 = X.p[, , , 4]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ trend * occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.1 + det.cov.2 * det.cov.3 +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- out$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p[, , 1, 3] * dat$X.p[, , 1, 4], along = 3) + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Site/year covariate on detection ---------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.6, 0.5) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5, 0.3, -0.4) +p.det <- length(alpha) +p.RE <- list() +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE) +y <- dat$y +X <- dat$X +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.cov.1 = X[, , 3]) +det.covs <- list(occ.cov.1 = X[, , 3]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ trend + occ.cov.1 +det.formula <- ~ occ.cov.1 +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$occ.cov.1[1, 1] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- dat$X.p[, , 1, 1:2] + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Site covariate on occurrence/detection ---------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.6) +p.occ <- length(beta) +trend <- FALSE +sp.only <- 2 +psi.RE <- list() +alpha <- c(-1, 0.5, 0.3, -0.4) +p.det <- length(alpha) +p.RE <- list() +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE) +y <- dat$y +X <- dat$X +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1], + occ.cov.1 = X[, , 2]) +det.covs <- list(occ.cov.1 = X[, , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ occ.cov.1 +det.formula <- ~ occ.cov.1 +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$occ.cov.1[1] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$occ.cov.1[1] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- dat$X.p[, , 1, 1:2] + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Random intercept on occurrence ------------------------------------------ +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.6, 0.5) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10), + sigma.sq.psi = c(1)) +alpha <- c(-1, 0.5, 0.3, -0.4) +p.det <- length(alpha) +p.RE <- list() +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.cov.1 = X[, , 3], + occ.factor.1 = X.re[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.cov.2 = X.p[, , , 3], + det.cov.3 = X.p[, , , 4]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ trend + occ.cov.1 + (1 | occ.factor.1) +det.formula <- ~ det.cov.1 + det.cov.1 + det.cov.2 + det.cov.3 +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$occ.cov.1[1, 1] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- abind(dat$X, dat$X.re, along = 3) + dimnames(X.0)[[3]] <- c('(Intercept)', 'trend', 'occ.cov.1', 'occ.factor.1') + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- dat$X.p[, , 1, ] + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Multiple random intercepts on occurrence -------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.6, 0.5) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10, 20), + sigma.sq.psi = c(1, 0.5)) +alpha <- c(-1, 0.5, 0.3, -0.4) +p.det <- length(alpha) +p.RE <- list() +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.cov.1 = X[, , 3], + occ.factor.1 = X.re[, , 1], + occ.factor.2 = X.re[, , 2]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.cov.2 = X.p[, , , 3], + det.cov.3 = X.p[, , , 4]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ trend + occ.cov.1 + (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ det.cov.1 + det.cov.1 + det.cov.2 + det.cov.3 +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$occ.cov.1[1, 1] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- abind(dat$X, dat$X.re, along = 3) + dimnames(X.0)[[3]] <- c('(Intercept)', 'trend', 'occ.cov.1', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- dat$X.p[, , 1, ] + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Occurrence REs only ----------------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- FALSE +sp.only <- 0 +psi.RE <- list(levels = c(10, 20), + sigma.sq.psi = c(1, 0.5)) +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list() +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1], + occ.factor.1 = X.re[, , 1], + occ.factor.2 = X.re[, , 2]) +det.covs <- list(int = X.p[, , , 1]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ (1 | occ.factor.1) + (1 | occ.factor.2) +det.formula <- ~ 1 +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$re.level.names))), + sort(unique(c(X.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- abind(dat$X, dat$X.re, along = 3) + dimnames(X.0)[[3]] <- c('(Intercept)', 'occ.factor.1', 'occ.factor.2') + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)) + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Random intercept on detection ------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list(levels = c(20), + sigma.sq.p = c(1)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re +X.p <- dat$X.p +X.p.re <- dat$X.p.re +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.factor.1 = X.p.re[, , , 1]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind(array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)), + array(dat$X.p.re[, , 1, ], dim = c(J, n.time.max, 1)), along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.factor.1') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Multiple random intercepts on detection --------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list(levels = c(20, 15), + sigma.sq.p = c(1, 0.5)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re +X.p <- dat$X.p +X.p.re <- dat$X.p.re +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ 1 +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind::abind(array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)), + array(dat$X.p.re[, , 1, ], dim = c(J, n.time.max, 2)), along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Multiple random intercepts with covariates ------------------------------ +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- FALSE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5) +p.det <- length(alpha) +p.RE <- list(levels = c(20, 15), + sigma.sq.p = c(1, 0.5)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re +X.p <- dat$X.p +X.p.re <- dat$X.p.re +occ.covs <- list(int = X[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ 1 +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { +# tmp.data <- data.list +# tmp.data$occ.covs$trend[3, ] <- NA +# expect_error(tPGOcc(occ.formula = occ.formula, +# det.formula = det.formula, +# data = tmp.data, +# n.batch = n.batch, +# batch.length = batch.length, +# tuning = list(rho = 1), +# n.omp.threads = 1, +# verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Multiple random intercepts with covariates on both ---------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.8) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5) +p.det <- length(alpha) +p.RE <- list(levels = c(20, 15), + sigma.sq.p = c(1, 0.5)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re +X.p <- dat$X.p +X.p.re <- dat$X.p.re +occ.covs <- list(int = X[, , 1], + trend = X[, , 2]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ trend +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, FALSE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Random intercepts on both ----------------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4) +p.occ <- length(beta) +trend <- FALSE +sp.only <- 0 +psi.RE <- list(levels = c(10), + sigma.sq.psi = c(0.8)) +alpha <- c(-1) +p.det <- length(alpha) +p.RE <- list(levels = c(20, 15), + sigma.sq.p = c(1, 0.5)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re +X.p <- dat$X.p +X.p.re <- dat$X.p.re +occ.covs <- list(int = X[, , 1], + occ.factor.1 = X.re[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ (1 | occ.factor.1) +det.formula <- ~ (1 | det.factor.1) + (1 | det.factor.2) +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + # data.list$occ.covs <- as.data.frame(data.list$occ.covs) + # data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + # data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, ignore.RE = TRUE, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind::abind(array(dat$X.p[, , 1, ], dim = c(J, n.time.max, 1)), + array(dat$X.p.re[, , 1, ], dim = c(J, n.time.max, 2)), along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Random intercepts and covariates on both -------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +beta <- c(0.4, 0.8) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list(levels = c(10), + sigma.sq.psi = c(0.8)) +alpha <- c(-1, 0.5) +p.det <- length(alpha) +p.RE <- list(levels = c(20, 15), + sigma.sq.p = c(1, 0.5)) +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE) +y <- dat$y +X <- dat$X +X.re <- dat$X.re +X.p <- dat$X.p +X.p.re <- dat$X.p.re +occ.covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.factor.1 = X.re[, , 1]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.factor.1 = X.p.re[, , , 1], + det.factor.2 = X.p.re[, , , 2]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ trend + (1 | occ.factor.1) +det.formula <- ~ det.cov.1 + (1 | det.factor.1) + (1 | det.factor.2) +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, TRUE) + expect_equal(out$psiRE, TRUE) +}) + +# Check RE levels --------------------- +test_that("random effect levels are correct", { + expect_equal(sort(unique(unlist(out$p.re.level.names))), + sort(unique(c(X.p.re)))) +}) + +# Check RE error ---------------------- +test_that("random effect gives error when non-numeric", { + data.list$occ.covs$occ.factor.1 <- factor(data.list$occ.covs$occ.factor.1) + data.list$det.covs$det.factor.1 <- factor(data.list$det.covs$det.factor.1) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + ar1 = TRUE, + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) + data.list$occ.covs$occ.factor.1 <- as.character(factor(data.list$occ.covs$occ.factor.1)) + data.list$det.covs$det.factor.1 <- as.character(factor(data.list$det.covs$det.factor.1)) + expect_error(out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 1)) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- abind::abind(dat$X, dat$X.re, along = 3) + dimnames(X.0)[[3]] <- c('(Intercept)', 'trend', 'occ.factor.1') + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + X.p.0 <- abind::abind(dat$X.p[, , 1, ], dat$X.p.re[, , 1, ], along = 3) + dimnames(X.p.0)[[3]] <- c('(Intercept)', 'det.cov.1', 'det.factor.1', 'det.factor.2') + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, max(n.rep, na.rm = TRUE))) +}) + +# Third dimension of y != max(n.rep) -------------------------------------- +# Sites +J.x <- 10 +J.y <- 10 +J <- J.x * J.y +n.time <- sample(2:10, J, replace = TRUE) +n.time.max <- max(n.time) +n.rep <- matrix(NA, J, max(n.time)) +for (j in 1:J) { + n.rep[j, 1:n.time[j]] <- sample(1:4, n.time[j], replace = TRUE) +} +n.rep.max <- 7 +beta <- c(0.4, 0.6, 0.5) +p.occ <- length(beta) +trend <- TRUE +sp.only <- 0 +psi.RE <- list() +alpha <- c(-1, 0.5, 0.3, -0.4) +p.det <- length(alpha) +p.RE <- list() +dat <- simTOcc(J.x = J.x, J.y = J.y, n.time = n.time, n.rep = n.rep, + beta = beta, alpha = alpha, sp.only = sp.only, trend = trend, + psi.RE = psi.RE, p.RE = p.RE, n.rep.max = n.rep.max) +y <- dat$y +X <- dat$X +X.p <- dat$X.p +occ.covs <- list(int = X[, , 1], + trend = X[, , 2], + occ.cov.1 = X[, , 3]) +det.covs <- list(int = X.p[, , , 1], + det.cov.1 = X.p[, , , 2], + det.cov.2 = X.p[, , , 3], + det.cov.3 = X.p[, , , 4]) + +data.list <- list(y = y, occ.covs = occ.covs, det.covs = det.covs) +# Priors +prior.list <- list(beta.normal = list(mean = 0, var = 2.72), + alpha.normal = list(mean = 0, var = 2.72)) +# Starting values +z.init <- apply(y, c(1, 2), function(a) as.numeric(sum(a, na.rm = TRUE) > 0)) +inits.list <- list(alpha = 0, beta = 0, z = z.init) + +n.batch <- 40 +batch.length <- 25 +n.samples <- n.batch * batch.length +n.report <- 100 + +occ.formula <- ~ trend + occ.cov.1 +det.formula <- ~ det.cov.1 + det.cov.1 + det.cov.2 + det.cov.3 +out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + inits = inits.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + priors = prior.list, + n.omp.threads = 1, + verbose = FALSE, + n.report = n.report, + n.burn = 400, + n.thin = 6, + n.chains = 2, + k.fold = 2, + k.fold.threads = 1) + +# Test to make sure it worked --------- +test_that("out is of class tPGOcc", { + expect_s3_class(out, "tPGOcc") +}) + +# Check cross-validation -------------- +test_that("cross-validation works", { + expect_equal(length(out$k.fold.deviance), 1) + expect_type(out$k.fold.deviance, "double") + expect_gt(out$k.fold.deviance, 0) +}) + +# Check random effects ---------------- +test_that("random effects are empty", { + expect_equal(out$pRE, FALSE) + expect_equal(out$psiRE, FALSE) +}) + +# Check output data output is correct - +test_that("out$y == y", { + expect_equal(out$y, dat$y) +}) + +# Check default priors ---------------- +test_that("default priors, inits, burn, thin work", { + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check summary ----------------------- +test_that("summary works", { + expect_output(summary(out)) +}) + +# Check verbose ----------------------- +test_that("verbose prints to the screen", { + + expect_output(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = TRUE, + n.report = n.report, + n.burn = 1, + n.thin = 1)) +}) + +# Check missing values ---------------- +test_that("missing value error handling works", { + tmp.data <- data.list + tmp.data$occ.covs$trend[3, ] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- 1 + tmp.data$det.covs$det.cov.1[1, 1, 1] <- NA + expect_error(tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE)) + tmp.data <- data.list + tmp.data$y[1, 1, 1] <- NA + out <- tPGOcc(occ.formula = occ.formula, + det.formula = det.formula, + data = tmp.data, + n.batch = n.batch, + batch.length = batch.length, + tuning = list(rho = 1), + n.omp.threads = 1, + verbose = FALSE) + expect_s3_class(out, "tPGOcc") +}) + +# Check waicOcc ----------------------- +test_that("waicOCC works for tPGOcc", { + # as.vector gets rid of names + waic.out <- as.vector(waicOcc(out)) + expect_equal(length(waic.out), 3) + expect_equal(waic.out[3], -2 * (waic.out[1] - waic.out[2])) +}) + +# Check fitted ------------------------ +test_that("fitted works for tPGOcc", { + fitted.out <- fitted(out) + expect_equal(length(fitted.out), 2) +}) + +# Check predictions ------------------- +test_that("predict works for tPGOcc", { + X.0 <- dat$X + pred.out <- predict(out, X.0, t.cols = 1:n.time.max) + expect_type(pred.out, "list") + expect_equal(dim(pred.out$psi.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) + expect_equal(dim(pred.out$z.0.samples), c(out$n.post * out$n.chains, J, n.time.max)) +}) +test_that("detection prediction works", { + J.str <- 100 + X.p.0 <- dat$X.p[, , 1, ] + pred.out <- predict(out, X.p.0, type = 'detection', t.cols = 1:n.time.max) + expect_type(pred.out, 'list') + expect_equal(dim(pred.out$p.0.samples), c(out$n.post * out$n.chains, J.str, n.time.max)) +}) + +# Check PPCs -------------------------- +test_that("posterior predictive checks work for tPGOcc", { + n.post.samples <- out$n.post * out$n.chains + ppc.out <- ppcOcc(out, 'chi-square', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, n.rep.max)) + + ppc.out <- ppcOcc(out, 'chi-square', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 1) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, J, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, J, n.time.max)) + + ppc.out <- ppcOcc(out, 'freeman-tukey', 2) + expect_type(ppc.out, "list") + expect_equal(dim(ppc.out$fit.y), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.rep), c(n.post.samples, n.time.max)) + expect_equal(dim(ppc.out$fit.y.group.quants), c(5, n.time.max, n.rep.max)) + expect_equal(dim(ppc.out$fit.y.rep.group.quants), c(5, n.time.max, n.rep.max)) +}) +