### Tests for eval_util_L/R ---------------------------------------------------- I <- 2 # Number of species J <- 2 # Number of sites K <- 2 # Number of replicates data <- occumbData( y = array(sample.int(I * J * K), dim = c(I, J, K)), spec_cov = list(cov1 = rnorm(I)), site_cov = list(cov2 = rnorm(J), cov3 = factor(1:J)), repl_cov = list(cov4 = matrix(rnorm(J * K), J, K))) # Fitting a null model (includes only species-specific intercepts) res0 <- occumb(data = data, n.chains = 1, n.adapt = 0, n.burnin = 0, n.thin = 1, n.iter = 10, verbose = FALSE) # Add species-specific effects of site covariates in occupancy probabilities res1 <- occumb(formula_psi = ~ cov2, data = data, n.chains = 1, n.adapt = 0, n.burnin = 0, n.thin = 1, n.iter = 10, verbose = FALSE) res1a <- occumb(formula_theta = ~ cov2, data = data, n.chains = 1, n.adapt = 0, n.burnin = 0, n.thin = 1, n.iter = 10, verbose = FALSE) res1b <- occumb(formula_phi = ~ cov2, data = data, n.chains = 1, n.adapt = 0, n.burnin = 0, n.thin = 1, n.iter = 10, verbose = FALSE) res2 <- occumb(formula_psi = ~ cov3, data = data, n.chains = 1, n.adapt = 0, n.burnin = 0, n.thin = 1, n.iter = 10, verbose = FALSE) res3 <- occumb(formula_psi = ~ cov2 * cov3, data = data, n.chains = 1, n.adapt = 0, n.burnin = 0, n.thin = 1, n.iter = 10, verbose = FALSE) # Add species covariate in the three parameters res4 <- occumb(formula_phi_shared = ~ cov1, data = data, n.chains = 1, n.adapt = 0, n.burnin = 0, n.thin = 1, n.iter = 10, verbose = FALSE) res5 <- occumb(formula_theta_shared = ~ cov1, data = data, n.chains = 1, n.adapt = 0, n.burnin = 0, n.thin = 1, n.iter = 10, verbose = FALSE) res6 <- occumb(formula_psi_shared = ~ cov1, data = data, n.chains = 1, n.adapt = 0, n.burnin = 0, n.thin = 1, n.iter = 10, verbose = FALSE) # Add replicate covariates res7 <- occumb(formula_phi = ~ cov4, data = data, n.chains = 1, n.adapt = 0, n.burnin = 0, n.thin = 1, n.iter = 10, verbose = FALSE) res8 <- occumb(formula_theta = ~ cov4, data = data, n.chains = 1, n.adapt = 0, n.burnin = 0, n.thin = 1, n.iter = 10, verbose = FALSE) test_that("eval_util_L() outputs a data frame with the additional Utility column", { settings <- data.frame(K = rep(1, 3), N = rep(1, 3), x = NA) # Null model test0 <- eval_util_L(settings, res0, cores = 1) checkmate::expect_data_frame(test0) expect_equal(colnames(test0), c(colnames(settings), "Utility")) expect_equal(test0[, -ncol(test0)], settings) # Model with site covariates test1 <- eval_util_L(settings, res1, cores = 1) checkmate::expect_data_frame(test1) expect_equal(colnames(test1), c(colnames(settings), "Utility")) expect_equal(test1[, -ncol(test1)], settings) test1a <- eval_util_L(settings, res1a, cores = 1) checkmate::expect_data_frame(test1a) expect_equal(colnames(test1a), c(colnames(settings), "Utility")) expect_equal(test1a[, -ncol(test1a)], settings) test1b <- eval_util_L(settings, res1b, cores = 1) checkmate::expect_data_frame(test1b) expect_equal(colnames(test1b), c(colnames(settings), "Utility")) expect_equal(test1b[, -ncol(test1b)], settings) test2 <- eval_util_L(settings, res2, cores = 1) checkmate::expect_data_frame(test2) expect_equal(colnames(test2), c(colnames(settings), "Utility")) expect_equal(test2[, -ncol(test2)], settings) test3 <- eval_util_L(settings, res3, cores = 1) checkmate::expect_data_frame(test3) expect_equal(colnames(test3), c(colnames(settings), "Utility")) expect_equal(test3[, -ncol(test3)], settings) # Model with species covariates test4 <- eval_util_L(settings, res4, cores = 1) checkmate::expect_data_frame(test4) expect_equal(colnames(test4), c(colnames(settings), "Utility")) expect_equal(test4[, -ncol(test4)], settings) test5 <- eval_util_L(settings, res5, cores = 1) checkmate::expect_data_frame(test5) expect_equal(colnames(test5), c(colnames(settings), "Utility")) expect_equal(test5[, -ncol(test5)], settings) test6 <- eval_util_L(settings, res6, cores = 1) checkmate::expect_data_frame(test6) expect_equal(colnames(test6), c(colnames(settings), "Utility")) expect_equal(test6[, -ncol(test6)], settings) # Use z, theta, phi arguments test0_z <- eval_util_L(settings, res0, z = array(1, c(1, I, J)), cores = 1) checkmate::expect_data_frame(test0_z) expect_equal(colnames(test0_z), c(colnames(settings), "Utility")) expect_equal(test0_z[, -ncol(test0_z)], settings) test0_theta1 <- eval_util_L(settings, res0, theta = matrix(runif(1 * I), 1, I), cores = 1) checkmate::expect_data_frame(test0_theta1) expect_equal(colnames(test0_theta1), c(colnames(settings), "Utility")) expect_equal(test0_theta1[, -ncol(test0_theta1)], settings) test0_theta2 <- eval_util_L(settings, res0, theta = array(runif(1 * I * J), c(1, I, J)), cores = 1) checkmate::expect_data_frame(test0_theta2) expect_equal(colnames(test0_theta2), c(colnames(settings), "Utility")) expect_equal(test0_theta2[, -ncol(test0_theta2)], settings) test0_phi1 <- eval_util_L(settings, res0, phi = matrix(runif(1 * I), 1, I), cores = 1) checkmate::expect_data_frame(test0_phi1) expect_equal(colnames(test0_phi1), c(colnames(settings), "Utility")) expect_equal(test0_phi1[, -ncol(test0_phi1)], settings) test0_phi2 <- eval_util_L(settings, res0, phi = array(runif(1 * I * J), c(1, I, J)), cores = 1) checkmate::expect_data_frame(test0_phi2) expect_equal(colnames(test0_phi2), c(colnames(settings), "Utility")) expect_equal(test0_phi2[, -ncol(test0_phi2)], settings) }) test_that("eval_util_R() outputs a data frame with the additional Utility column", { settings <- data.frame(J = rep(1, 3), K = rep(1, 3), N = rep(1, 3), x = NA) # Null model test0 <- eval_util_R(settings, res0, cores = 1) checkmate::expect_data_frame(test0) expect_equal(colnames(test0), c(colnames(settings), "Utility")) expect_equal(test0[, -ncol(test0)], settings) test0x <- eval_util_R(settings, res0, N_rep = 2, cores = 1) checkmate::expect_data_frame(test0x) expect_equal(colnames(test0x), c(colnames(settings), "Utility")) expect_equal(test0x[, -ncol(test0x)], settings) # Model with site covariates test1 <- eval_util_R(settings, res1, cores = 1) checkmate::expect_data_frame(test1) expect_equal(colnames(test1), c(colnames(settings), "Utility")) expect_equal(test1[, -ncol(test1)], settings) test1x <- eval_util_R(settings, res1, N_rep = 2, cores = 1) checkmate::expect_data_frame(test1x) expect_equal(colnames(test1x), c(colnames(settings), "Utility")) expect_equal(test1x[, -ncol(test1x)], settings) test1a <- eval_util_R(settings, res1a, cores = 1) checkmate::expect_data_frame(test1a) expect_equal(colnames(test1a), c(colnames(settings), "Utility")) expect_equal(test1a[, -ncol(test1a)], settings) test1ax <- eval_util_R(settings, res1a, N_rep = 2, cores = 1) checkmate::expect_data_frame(test1ax) expect_equal(colnames(test1ax), c(colnames(settings), "Utility")) expect_equal(test1ax[, -ncol(test1ax)], settings) test1b <- eval_util_R(settings, res1b, cores = 1) checkmate::expect_data_frame(test1b) expect_equal(colnames(test1b), c(colnames(settings), "Utility")) expect_equal(test1b[, -ncol(test1b)], settings) test1bx <- eval_util_R(settings, res1b, N_rep = 2, cores = 1) checkmate::expect_data_frame(test1bx) expect_equal(colnames(test1bx), c(colnames(settings), "Utility")) expect_equal(test1bx[, -ncol(test1bx)], settings) test2 <- eval_util_R(settings, res2, cores = 1) checkmate::expect_data_frame(test2) expect_equal(colnames(test2), c(colnames(settings), "Utility")) expect_equal(test2[, -ncol(test2)], settings) test2x <- eval_util_R(settings, res2, N_rep = 2, cores = 1) checkmate::expect_data_frame(test2x) expect_equal(colnames(test2x), c(colnames(settings), "Utility")) expect_equal(test2x[, -ncol(test2x)], settings) test3 <- eval_util_R(settings, res3, cores = 1) checkmate::expect_data_frame(test3) expect_equal(colnames(test3), c(colnames(settings), "Utility")) expect_equal(test3[, -ncol(test3)], settings) test3x <- eval_util_R(settings, res3, N_rep = 2, cores = 1) checkmate::expect_data_frame(test3x) expect_equal(colnames(test3x), c(colnames(settings), "Utility")) expect_equal(test3x[, -ncol(test3x)], settings) # Model with species covariates test4 <- eval_util_R(settings, res4, cores = 1) checkmate::expect_data_frame(test4) expect_equal(colnames(test4), c(colnames(settings), "Utility")) expect_equal(test4[, -ncol(test4)], settings) test4x <- eval_util_R(settings, res4, N_rep = 2, cores = 1) checkmate::expect_data_frame(test4x) expect_equal(colnames(test4x), c(colnames(settings), "Utility")) expect_equal(test4x[, -ncol(test4x)], settings) test5 <- eval_util_R(settings, res5, cores = 1) checkmate::expect_data_frame(test5) expect_equal(colnames(test5), c(colnames(settings), "Utility")) expect_equal(test5[, -ncol(test5)], settings) test5x <- eval_util_R(settings, res5, N_rep = 2, cores = 1) checkmate::expect_data_frame(test5x) expect_equal(colnames(test5x), c(colnames(settings), "Utility")) expect_equal(test5x[, -ncol(test5x)], settings) test6 <- eval_util_R(settings, res6, cores = 1) checkmate::expect_data_frame(test6) expect_equal(colnames(test6), c(colnames(settings), "Utility")) expect_equal(test6[, -ncol(test6)], settings) test6x <- eval_util_R(settings, res6, N_rep = 2, cores = 1) checkmate::expect_data_frame(test6x) expect_equal(colnames(test6x), c(colnames(settings), "Utility")) expect_equal(test6x[, -ncol(test6x)], settings) # Use psi, theta, phi arguments test0_psi1 <- eval_util_R(settings, res0, psi = matrix(runif(1 * I), 1, I), cores = 1) checkmate::expect_data_frame(test0_psi1) expect_equal(colnames(test0_psi1), c(colnames(settings), "Utility")) expect_equal(test0_psi1[, -ncol(test0_psi1)], settings) test0_psi2 <- eval_util_R(settings, res0, psi = array(runif(1 * I * J), c(1, I, J)), cores = 1) checkmate::expect_data_frame(test0_psi2) expect_equal(colnames(test0_psi2), c(colnames(settings), "Utility")) expect_equal(test0_psi2[, -ncol(test0_psi2)], settings) test0_theta1 <- eval_util_R(settings, res0, theta = matrix(runif(1 * I), 1, I), cores = 1) checkmate::expect_data_frame(test0_theta1) expect_equal(colnames(test0_theta1), c(colnames(settings), "Utility")) expect_equal(test0_theta1[, -ncol(test0_theta1)], settings) test0_theta2 <- eval_util_R(settings, res0, theta = array(runif(1 * I * J), c(1, I, J)), cores = 1) checkmate::expect_data_frame(test0_theta2) expect_equal(colnames(test0_theta2), c(colnames(settings), "Utility")) expect_equal(test0_theta2[, -ncol(test0_theta2)], settings) test0_phi1 <- eval_util_R(settings, res0, phi = matrix(runif(1 * I), 1, I), cores = 1) checkmate::expect_data_frame(test0_phi1) expect_equal(colnames(test0_phi1), c(colnames(settings), "Utility")) expect_equal(test0_phi1[, -ncol(test0_phi1)], settings) test0_phi2 <- eval_util_R(settings, res0, phi = array(runif(1 * I * J), c(1, I, J)), cores = 1) checkmate::expect_data_frame(test0_phi2) expect_equal(colnames(test0_phi2), c(colnames(settings), "Utility")) expect_equal(test0_phi2[, -ncol(test0_phi2)], settings) }) ### Tests for list_cond_L ------------------------------------------------------ I <- 2 # Number of species J <- 50 # Number of sites K <- 2 # Number of replicates data <- occumbData( y = array(sample.int(I * J * K), dim = c(I, J, K)), spec_cov = list(cov1 = rnorm(I)), site_cov = list(cov2 = rnorm(J), cov3 = factor(1:J)), repl_cov = list(cov4 = matrix(rnorm(J * K), J, K))) res0 <- occumb(data = data, n.chains = 1, n.adapt = 0, n.burnin = 0, n.thin = 1, n.iter = 10, verbose = FALSE) budget <- 850000; lambda1 <- 0.01; lambda2 <- 5000 test <- list_cond_L(budget, lambda1, lambda2, res0) test_that("list_cond_L() outputs a data frame with correct columns", { checkmate::expect_data_frame(test) expect_equal(colnames(test), c("budget", "lambda1", "lambda2", "K", "N")) }) test_that("Elements of list_cond_L() output are correct", { max_K <- floor(budget / (lambda2 * J)) N <- (budget - lambda2 * J * seq_len(max_K)) / (lambda1 * J * seq_len(max_K)) expect_equal(nrow(test), max_K) expect_equal(test$budget, rep(budget, max_K)) expect_equal(test$lambda1, rep(lambda1, max_K)) expect_equal(test$lambda2, rep(lambda2, max_K)) expect_equal(test$K, seq_len(max_K)) expect_equal(test$N, N) }) test_that("K argument of list_cond_L() work correctly", { testK <- c(1, 3) N <- (budget - lambda2 * J * testK) / (lambda1 * J * testK) test <- list_cond_L(budget, lambda1, lambda2, res0, K = testK) expect_equal(nrow(test), length(testK)) expect_equal(test$budget, rep(budget, length(testK))) expect_equal(test$lambda1, rep(lambda1, length(testK))) expect_equal(test$lambda2, rep(lambda2, length(testK))) expect_equal(test$K, testK) expect_equal(test$N, N) }) test_that("Quality controls for list_cond_L() work correctly", { max_K <- floor(budget / (lambda2 * J)) expect_error(list_cond_L(-1, lambda1, lambda2, res0), "Negative 'budget' value.") expect_error(list_cond_L(budget, -1, lambda2, res0), "Negative 'lambda1' value.") expect_error(list_cond_L(budget, lambda1, -1, res0), "Negative 'lambda2' value.") expect_error(list_cond_L(budget, lambda1, lambda2, 0), "An occumbFit class object is expected for 'fit'") expect_error(list_cond_L(0, lambda1, lambda2, res0), "Impossible to have > 0 replicates per site under the given budget, cost, and the number of sites.") expect_error(list_cond_L(budget, lambda1, lambda2, res0, K = c(0, 1)), "'K' contains values less than one.") expect_error(list_cond_L(budget, lambda1, lambda2, res0, K = seq_len(max_K + 1)), paste("A value of 'K' greater than", max_K, "is not feasible under the given budget, cost, and the number of sites.")) }) ### Tests for list_cond_R ------------------------------------------------------ budget <- 100000; lambda1 <- 0.01; lambda2 <- 5000; lambda3 <- 5000 max_K <- find_maxK(budget, lambda2, lambda3) test <- list_cond_R(budget, lambda1, lambda2, lambda3) test_that("list_cond_R() outputs a data frame with correct columns", { checkmate::expect_data_frame(test) expect_equal(colnames(test), c("budget", "lambda1", "lambda2", "lambda3", "J", "K", "N")) }) test_that("Elements of list_cond_R() output are correct", { J_valid <- list(); J <- seq_len(100) for (k in seq_len(max_K)) J_valid[[k]] <- J[budget - lambda2 * J * k - lambda3 * J > 0] nrow_ans <- length(unlist(J_valid)) J_ans <- K_ans <- vector() for (k in seq_len(max_K)) { J_ans <- c(J_ans, J_valid[[k]]) K_ans <- c(K_ans, rep(k, sapply(J_valid, length)[k])) } N_ans <- (budget - lambda2 * J_ans * K_ans - lambda3 * J_ans) / (lambda1 * J_ans * K_ans) expect_equal(nrow(test), nrow_ans) expect_equal(test$budget, rep(budget, nrow_ans)) expect_equal(test$lambda1, rep(lambda1, nrow_ans)) expect_equal(test$lambda2, rep(lambda2, nrow_ans)) expect_equal(test$lambda3, rep(lambda2, nrow_ans)) expect_equal(test$J, J_ans) expect_equal(test$K, K_ans) expect_equal(test$N, N_ans) }) test_that("J argument of list_cond_R() work correctly", { J <- seq(2, 10, 2) J_valid <- list() for (k in seq_len(max_K)) J_valid[[k]] <- J[budget - lambda2 * J * k - lambda3 * J > 0] nrow_ans <- length(unlist(J_valid)) J_ans <- K_ans <- vector() for (k in seq_len(max_K)) { J_ans <- c(J_ans, J_valid[[k]]) K_ans <- c(K_ans, rep(k, sapply(J_valid, length)[k])) } N_ans <- (budget - lambda2 * J_ans * K_ans - lambda3 * J_ans) / (lambda1 * J_ans * K_ans) testJ <- list_cond_R(budget, lambda1, lambda2, lambda3, J = J) expect_equal(nrow(testJ), nrow_ans) expect_equal(testJ$budget, rep(budget, nrow_ans)) expect_equal(testJ$lambda1, rep(lambda1, nrow_ans)) expect_equal(testJ$lambda2, rep(lambda2, nrow_ans)) expect_equal(testJ$lambda3, rep(lambda2, nrow_ans)) expect_equal(testJ$J, J_ans) expect_equal(testJ$K, K_ans) expect_equal(testJ$N, N_ans) }) test_that("K argument of list_cond_R() work correctly", { K <- c(1, 3) J_valid <- list(); J <- seq_len(100) for (k in K) J_valid[[k]] <- J[budget - lambda2 * J * k - lambda3 * J > 0] nrow_ans <- length(unlist(J_valid)) J_ans <- K_ans <- vector() for (k in K) { J_ans <- c(J_ans, J_valid[[k]]) K_ans <- c(K_ans, rep(k, sapply(J_valid, length)[k])) } N_ans <- (budget - lambda2 * J_ans * K_ans - lambda3 * J_ans) / (lambda1 * J_ans * K_ans) testK <- list_cond_R(budget, lambda1, lambda2, lambda3, K = K) expect_equal(nrow(testK), nrow_ans) expect_equal(testK$budget, rep(budget, nrow_ans)) expect_equal(testK$lambda1, rep(lambda1, nrow_ans)) expect_equal(testK$lambda2, rep(lambda2, nrow_ans)) expect_equal(testK$lambda3, rep(lambda2, nrow_ans)) expect_equal(testK$J, J_ans) expect_equal(testK$K, K_ans) expect_equal(testK$N, N_ans) }) test_that("Quality controls for list_cond_R() work correctly", { expect_error(list_cond_R(-1, lambda1, lambda2, lambda3), "Negative 'budget' value.") expect_error(list_cond_R(budget, -1, lambda2, lambda3), "Negative 'lambda1' value.") expect_error(list_cond_R(budget, lambda1, -1, lambda3), "Negative 'lambda2' value.") expect_error(list_cond_R(budget, lambda1, lambda2, -1), "Negative 'lambda3' value.") expect_error(list_cond_R(budget, lambda1, lambda2, lambda3, J = c(0, 1)), "'J' contains values less than one.") expect_error(list_cond_R(budget, lambda1, lambda2, lambda3, K = c(0, 1)), "'K' contains values less than one.") expect_error(list_cond_R(budget, lambda1, lambda2, lambda3, K = c(2, 1)), "'K' must be in ascending order.") expect_error(list_cond_R(budget, lambda1, lambda2, lambda3, K = c(20)), paste("No valid combination of 'J' and 'K' under the given budget and cost.")) }) ### Tests for find_max_J/K ----------------------------------------------------- test_that("find_maxJ/K() returns correct value", { budget <- 100000; lambda2 <- 5000; lambda3 <- 5000 J <- seq_len(1E3) J_ans <- max(J[budget - lambda2 * J - lambda3 * J > 0]) K <- seq_len(1E3) K_ans <- max(K[budget - lambda2 * K - lambda3 > 0]) expect_equal(find_maxJ(budget, lambda2, lambda3), J_ans) expect_equal(find_maxK(budget, lambda2, lambda3), K_ans) }) test_that("find_maxJ/K() returns zero when budget is too small", { expect_equal(find_maxJ(10, lambda2, lambda3), 0) expect_equal(find_maxK(10, lambda2, lambda3), 0) }) test_that("find_maxJ/K() throws an error when the budget is too large", { expect_error(find_maxJ(1E16, lambda2, lambda3), "Maximum `J` value seems too large under the specified budget and cost values: consider using the `J` argument to specify a smaller set of `J` values of interest.") expect_error(find_maxK(1E16, lambda2, lambda3), "Maximum `K` value seems too large under the specified budget and cost values: consider using the `K` argument to specify a smaller set of `K` values of interest.") }) ### Tests for qc_eval_util_L --------------------------------------------------- I <- dim(res0@data@y)[1] J <- dim(res0@data@y)[2] df_test <- data.frame(K = rep(1, 2), N = rep(1, 2)) arr_test <- array(1, dim = c(1, I, J)) test_that("qc_eval_util_L() blocks inappropriate settings", { expect_error(qc_eval_util_L(data.frame(Kx = rep(1, 2), N = rep(1, 2)), res0, NULL, NULL, NULL), "The 'settings' argument does not contain column 'K'.") expect_error(qc_eval_util_L(data.frame(K = rep(1, 2), Nx = rep(1, 2)), res0, NULL, NULL, NULL), "The 'settings' argument does not contain column 'N'.") expect_error(qc_eval_util_L(data.frame(K = rep(0, 2), N = rep(1, 2)), res0, NULL, NULL, NULL), "'K' contains values less than one.") expect_error(qc_eval_util_L(data.frame(K = rep(1, 2), N = rep(0, 2)), res0, NULL, NULL, NULL), "'N' contains values less than one.") }) test_that("qc_eval_util_L() allows sufficient arguments", { expect_invisible(qc_eval_util_L(df_test, res0, NULL, NULL, NULL)) expect_invisible(qc_eval_util_L(df_test, NULL, arr_test, arr_test, arr_test)) expect_invisible(qc_eval_util_L(df_test, res0, arr_test, NULL, NULL)) expect_invisible(qc_eval_util_L(df_test, res0, NULL, arr_test, NULL)) expect_invisible(qc_eval_util_L(df_test, res0, NULL, NULL, arr_test)) expect_invisible(qc_eval_util_L(df_test, res0, arr_test, arr_test, NULL)) expect_invisible(qc_eval_util_L(df_test, res0, arr_test, NULL, arr_test)) expect_invisible(qc_eval_util_L(df_test, res0, NULL, arr_test, arr_test)) expect_invisible(qc_eval_util_L(df_test, res0, arr_test, arr_test, arr_test)) }) test_that("qc_eval_util_L() blocks insufficient arguments", { error_message <- "Parameter values are not fully specified: use fit argument or otherwise use all of z, theta, phi arguments." expect_error(qc_eval_util_L(df_test, NULL, NULL, NULL, NULL), error_message) expect_error(qc_eval_util_L(df_test, NULL, arr_test, NULL, NULL), error_message) expect_error(qc_eval_util_L(df_test, NULL, NULL, arr_test, NULL), error_message) expect_error(qc_eval_util_L(df_test, NULL, NULL, NULL, arr_test), error_message) expect_error(qc_eval_util_L(df_test, NULL, NULL, arr_test, arr_test), error_message) expect_error(qc_eval_util_L(df_test, NULL, arr_test, NULL, arr_test), error_message) expect_error(qc_eval_util_L(df_test, NULL, arr_test, arr_test, NULL), error_message) }) test_that("qc_eval_util_L() blocks models with replicate-specific parameters", { expect_error(qc_eval_util_L(df_test, res7, NULL, NULL, NULL), "'fit' contains replicate-specific phi: specify appropriate phi values via the 'phi' argument to run.") expect_error(qc_eval_util_L(df_test, res8, NULL, NULL, NULL), "'fit' contains replicate-specific theta: specify appropriate theta values via the 'theta' argument to run.") }) test_that("qc_eval_util_L() blocks dimension mismatch between z, theta, phi and fit", { expect_error(qc_eval_util_L(df_test, res0, array(1, dim = c(1, I + 1, J)), NULL, NULL), paste0("Mismatch in species dimension: dim\\(z\\)\\[2\\] must be ", I, ".\n")) expect_error(qc_eval_util_L(df_test, res0, array(1, dim = c(1, I, J + 1)), NULL, NULL), paste0("Mismatch in site dimension: dim\\(z\\)\\[3\\] must be ", J, ".\n")) expect_error(qc_eval_util_L(df_test, res0, NULL, array(1, dim = c(1, I + 1, J)), NULL), paste0("Mismatch in species dimension: dim\\(theta\\)\\[2\\] must be ", I, ".\n")) expect_error(qc_eval_util_L(df_test, res0, NULL, array(1, dim = c(1, I, J + 1)), NULL), paste0("Mismatch in site dimension: dim\\(theta\\)\\[3\\] must be ", J, ".\n")) expect_error(qc_eval_util_L(df_test, res0, NULL, NULL, array(1, dim = c(1, I + 1, J))), paste0("Mismatch in species dimension: dim\\(phi\\)\\[2\\] must be ", I, ".\n")) expect_error(qc_eval_util_L(df_test, res0, NULL, NULL, array(1, dim = c(1, I, J + 1))), paste0("Mismatch in site dimension: dim\\(phi\\)\\[3\\] must be ", J, ".\n")) expect_error(qc_eval_util_L(df_test, NULL, arr_test, array(1, dim = c(1, I + 1, J)), arr_test), "Mismatch in species dimension: dim\\(z\\)\\[2\\], dim\\(theta\\)\\[2\\], and dim\\(phi\\)\\[2\\] must be equal.") expect_error(qc_eval_util_L(df_test, NULL, arr_test, arr_test, array(1, dim = c(1, I + 1, J))), "Mismatch in species dimension: dim\\(z\\)\\[2\\], dim\\(theta\\)\\[2\\], and dim\\(phi\\)\\[2\\] must be equal.") expect_error(qc_eval_util_L(df_test, NULL, arr_test, array(1, dim = c(1, I, J + 1)), arr_test), "Mismatch in site dimension: dim\\(z\\)\\[3\\], dim\\(theta\\)\\[3\\], and dim\\(phi\\)\\[3\\] must be equal.") expect_error(qc_eval_util_L(df_test, NULL, arr_test, arr_test, array(1, dim = c(1, I, J + 1))), "Mismatch in site dimension: dim\\(z\\)\\[3\\], dim\\(theta\\)\\[3\\], and dim\\(phi\\)\\[3\\] must be equal.") expect_error(qc_eval_util_L(df_test, NULL, arr_test, array(1, dim = c(1, I, J + 1)), array(1, dim = c(1, I))), "Mismatch in site dimension: dim\\(z\\)\\[3\\] and dim\\(theta\\)\\[3\\] must be equal.") expect_error(qc_eval_util_L(df_test, NULL, arr_test, array(1, dim = c(1, I)), array(1, dim = c(1, I, J + 1))), "Mismatch in site dimension: dim\\(z\\)\\[3\\] and dim\\(phi\\)\\[3\\] must be equal.") }) ### Tests for qc_eval_util_R --------------------------------------------------- I <- dim(res0@data@y)[1] J <- dim(res0@data@y)[2] df_test <- data.frame(J = rep(1, 2), K = rep(1, 2), N = rep(1, 2)) arr_test <- array(1, dim = c(1, I, J)) test_that("qc_eval_util_R() blocks inappropriate settings", { expect_error(qc_eval_util_R(data.frame(Jx = rep(1, 2), K = rep(1, 2), N = rep(1, 2)), res0), "The 'settings' argument does not contain column 'J'.") expect_error(qc_eval_util_R(data.frame(J = rep(1, 2), Kx = rep(1, 2), N = rep(1, 2)), res0), "The 'settings' argument does not contain column 'K'.") expect_error(qc_eval_util_R(data.frame(J = rep(1, 2), K = rep(1, 2), Nx = rep(1, 2)), res0), "The 'settings' argument does not contain column 'N'.") expect_error(qc_eval_util_R(data.frame(J = rep(0, 2), K = rep(1, 2), N = rep(1, 2)), res0), "'J' contains values less than one.") expect_error(qc_eval_util_R(data.frame(J = rep(1, 2), K = rep(0, 2), N = rep(1, 2)), res0), "'K' contains values less than one.") expect_error(qc_eval_util_R(data.frame(J = rep(1, 2), K = rep(1, 2), N = rep(0, 2)), res0), "'N' contains values less than one.") }) test_that("qc_eval_util_R() allows sufficient arguments", { expect_invisible(qc_eval_util_R(df_test, res0, NULL, NULL, NULL)) expect_invisible(qc_eval_util_R(df_test, NULL, arr_test, arr_test, arr_test)) expect_invisible(qc_eval_util_R(df_test, res0, arr_test, NULL, NULL)) expect_invisible(qc_eval_util_R(df_test, res0, NULL, arr_test, NULL)) expect_invisible(qc_eval_util_R(df_test, res0, NULL, NULL, arr_test)) expect_invisible(qc_eval_util_R(df_test, res0, arr_test, arr_test, NULL)) expect_invisible(qc_eval_util_R(df_test, res0, arr_test, NULL, arr_test)) expect_invisible(qc_eval_util_R(df_test, res0, NULL, arr_test, arr_test)) expect_invisible(qc_eval_util_R(df_test, res0, arr_test, arr_test, arr_test)) }) test_that("qc_eval_util_R() blocks insufficient arguments", { error_message <- "Parameter values are not fully specified: use fit argument or otherwise use all of psi, theta, phi arguments." expect_error(qc_eval_util_R(df_test, NULL, NULL, NULL, NULL), error_message) expect_error(qc_eval_util_R(df_test, NULL, arr_test, NULL, NULL), error_message) expect_error(qc_eval_util_R(df_test, NULL, NULL, arr_test, NULL), error_message) expect_error(qc_eval_util_R(df_test, NULL, NULL, NULL, arr_test), error_message) expect_error(qc_eval_util_R(df_test, NULL, NULL, arr_test, arr_test), error_message) expect_error(qc_eval_util_R(df_test, NULL, arr_test, NULL, arr_test), error_message) expect_error(qc_eval_util_R(df_test, NULL, arr_test, arr_test, NULL), error_message) }) test_that("qc_eval_util_R() blocks models with replicate-specific parameters", { expect_error(qc_eval_util_R(df_test, res7, NULL, NULL, NULL), "'fit' contains replicate-specific phi: specify appropriate phi values via the 'phi' argument to run.") expect_error(qc_eval_util_R(df_test, res8, NULL, NULL, NULL), "'fit' contains replicate-specific theta: specify appropriate theta values via the 'theta' argument to run.") }) test_that("qc_eval_util_R() blocks species/site dimension mismatch between psi, theta, phi, and fit", { expect_error(qc_eval_util_R(df_test, res0, array(1, dim = c(1, I + 1, J)), NULL, NULL), paste0("Mismatch in species dimension: dim\\(psi\\)\\[2\\] must be ", I, ".\n")) expect_error(qc_eval_util_R(df_test, res0, array(1, dim = c(1, I, J + 1)), NULL, NULL), paste0("Mismatch in site dimension: dim\\(psi\\)\\[3\\] must be ", J, ".\n")) expect_error(qc_eval_util_R(df_test, res0, NULL, array(1, dim = c(1, I + 1, J)), NULL), paste0("Mismatch in species dimension: dim\\(theta\\)\\[2\\] must be ", I, ".\n")) expect_error(qc_eval_util_R(df_test, res0, NULL, array(1, dim = c(1, I, J + 1)), NULL), paste0("Mismatch in site dimension: dim\\(theta\\)\\[3\\] must be ", J, ".\n")) expect_error(qc_eval_util_R(df_test, res0, NULL, NULL, array(1, dim = c(1, I + 1, J))), paste0("Mismatch in species dimension: dim\\(phi\\)\\[2\\] must be ", I, ".\n")) expect_error(qc_eval_util_R(df_test, res0, NULL, NULL, array(1, dim = c(1, I, J + 1))), paste0("Mismatch in site dimension: dim\\(phi\\)\\[3\\] must be ", J, ".\n")) expect_error(qc_eval_util_R(df_test, NULL, arr_test, array(1, dim = c(1, I + 1, J)), arr_test), "Mismatch in species dimension: dim\\(psi\\)\\[2\\], dim\\(theta\\)\\[2\\], and dim\\(phi\\)\\[2\\] must be equal.") expect_error(qc_eval_util_R(df_test, NULL, arr_test, arr_test, array(1, dim = c(1, I + 1, J))), "Mismatch in species dimension: dim\\(psi\\)\\[2\\], dim\\(theta\\)\\[2\\], and dim\\(phi\\)\\[2\\] must be equal.") expect_error(qc_eval_util_R(df_test, NULL, arr_test, array(1, dim = c(1, I, J + 1)), arr_test), "Mismatch in site dimension: dim\\(psi\\)\\[3\\], dim\\(theta\\)\\[3\\], and dim\\(phi\\)\\[3\\] must be equal.") expect_error(qc_eval_util_R(df_test, NULL, arr_test, arr_test, array(1, dim = c(1, I, J + 1))), "Mismatch in site dimension: dim\\(psi\\)\\[3\\], dim\\(theta\\)\\[3\\], and dim\\(phi\\)\\[3\\] must be equal.") expect_error(qc_eval_util_R(df_test, NULL, arr_test, array(1, dim = c(1, I, J + 1)), array(1, dim = c(1, I))), "Mismatch in site dimension: dim\\(psi\\)\\[3\\] and dim\\(theta\\)\\[3\\] must be equal.") expect_error(qc_eval_util_R(df_test, NULL, arr_test, array(1, dim = c(1, I)), array(1, dim = c(1, I, J + 1))), "Mismatch in site dimension: dim\\(psi\\)\\[3\\] and dim\\(phi\\)\\[3\\] must be equal.") expect_error(qc_eval_util_R(df_test, NULL, array(1, dim = c(1, I)), arr_test, array(1, dim = c(1, I, J + 1))), "Mismatch in site dimension: dim\\(theta\\)\\[3\\] and dim\\(phi\\)\\[3\\] must be equal.") }) ### Tests for eutil ------------------------------------------------------------ I <- 20; J <- 5; K <- 4; N <- 100; M <- 2 seed <- rnorm(1) z <- array(rbinom(M * I * J, 1, 0.8), dim = c(M, I, J)) theta <- array(runif(M * I * J, min = 0.8), dim = c(M, I, J)) phi <- array(rgamma(M * I * J, 1), dim = c(M, I, J)) test_that("eutil() works as expected for local scale", { ## * Tests are available only for non-parallel computations * # N_rep = 1 ans <- with_seed(seed, { util_rep <- vector(length = M) for (n in seq_len(M)) util_rep[n] <- cutil_local(z[n, , ], theta[n, , ], phi[n, , ], K, N) mean(util_rep)} ) expect_equal( with_seed(seed, eutil(z, theta, phi, K, N, scale = "local", N_rep = 1, cores = 1)), ans ) # rep > 1 ans <- with_seed(seed, { util_rep <- vector(length = M * 2) n <- rep(seq_len(M), each = 2) for (m in seq_along(n)) util_rep[m] <- cutil_local(z[n[m], , ], theta[n[m], , ], phi[n[m], , ], K, N) mean(util_rep)} ) expect_equal( with_seed(seed, eutil(z, theta, phi, K, N, scale = "local", N_rep = 2, cores = 1)), ans ) }) test_that("eutil() works as expected for regional scale", { ## * Tests are available only for non-parallel computations * # rep = 1 ans <- with_seed(seed, { util_rep <- vector(length = M) for (n in seq_len(M)) util_rep[n] <- cutil_regional(z[n, , ], theta[n, , ], phi[n, , ], K, N) mean(util_rep)} ) expect_equal( with_seed(seed, eutil(z, theta, phi, K, N, scale = "regional", N_rep = 1, cores = 1)), ans ) # rep > 1 ans <- with_seed(seed, { util_rep <- vector(length = M * 2) n <- rep(seq_len(M), each = 2) for (m in seq_along(n)) util_rep[m] <- cutil_regional(z[n[m], , ], theta[n[m], , ], phi[n[m], , ], K, N) mean(util_rep)} ) expect_equal( with_seed(seed, eutil(z, theta, phi, K, N, scale = "regional", N_rep = 2, cores = 1)), ans ) }) test_that("eutil() runs in parallel", { expect_visible( eutil(z, theta, phi, K, N, scale = "local", N_rep = 1, cores = 2) ) expect_visible( eutil(z, theta, phi, K, N, scale = "regional", N_rep = 1, cores = 2) ) }) ### Tests for cutil ------------------------------------------------------------ I <- 20; J <- 5; K <- 4; N <- 100 u <- r <- pi <- array(dim = c(I, J, K)); pi[1] <- NaN while(any(is.nan(pi))) { z <- matrix(rbinom(I * J, 1, 0.8), I, J) theta <- matrix(runif(I * J, min = 0.8), I, J) phi <- matrix(rgamma(I * J, 1), I, J) seed <- rnorm(1) set.seed(seed) for (k in seq_len(K)) { u[, , k] <- rbinom(I * J, 1, z * theta) r[, , k] <- rgamma(I * J, phi, 1) } for (k in seq_len(K)) { for (j in seq_len(J)) { for (i in seq_len(I)) { pi[i, j, k] <- u[i, j, k] * r[i, j, k] / sum(u[, j, k] * r[, j, k]) } } } } test_that("cutil_local() works as expected", { ans <- with_seed(seed, sum(predict_detect_probs_local(predict_pi(z, theta, phi, K), N)) / J) expect_equal(with_seed(seed, cutil_local(z, theta, phi, K, N)), ans) }) test_that("cutil_regional() works as expected", { ans <- with_seed(seed, sum(predict_detect_probs_regional(predict_pi(z, theta, phi, K), N))) expect_equal(with_seed(seed, cutil_regional(z, theta, phi, K, N)), ans) }) test_that("predict_detect_probs_local() works as expected", { ans <- matrix(nrow = I, ncol = J) for (i in seq_len(I)) { for (j in seq_len(J)) { ans[i, j] <- 1 - prod((1 - pi[i, j, ])^N) } } expect_equal(predict_detect_probs_local(pi, N), ans) }) test_that("predict_detect_probs_regional() works as expected", { ans <- vector(length = I) for (i in seq_len(I)) ans[i] <- 1 - prod((1 - pi[i, , ])^N) expect_equal(predict_detect_probs_regional(pi, N), ans) })