Merge pull request #92 from jsocolar/get-z-tests

some early tests

R/get_Z.R

@@ -416,6 +416,10 @@ forward_sim <- function(init, colo, ex, sample = FALSE){
   assertthat::assert_that(is.numeric(init))
   assertthat::assert_that(length(init) == 1)
   assertthat::assert_that(init >= 0 & init <= 1)
+  assertthat::assert_that(all(colo >= 0, na.rm = TRUE))
+  assertthat::assert_that(all(colo <= 1, na.rm = TRUE))
+  assertthat::assert_that(all(ex >= 0, na.rm = TRUE))
+  assertthat::assert_that(all(ex <= 1, na.rm = TRUE))
 
   out <- rep(NA, length_out)
   if(sample){

R/single_C-prediction-epred.R

@@ -4,6 +4,9 @@
 #' @param prep Output of \code{brms::prepare_predictions}. See brms custom 
 #' families vignette at 
 #' https://cran.r-project.org/web/packages/brms/vignettes/brms_customfamilies.html
+#' @param ... unused additional arguments. See brms custom 
+#' families vignette at 
+#' https://cran.r-project.org/web/packages/brms/vignettes/brms_customfamilies.html
 #' @return Posterior predictions
 posterior_predict_occupancy_single_C <- function(i, prep, ...) {
   mu <- brms::get_dpar(prep, "mu", i = i)

tests/testthat/test-get_Z.R

@@ -0,0 +1,185 @@
+test_that("get_Z gives valid returns", {
+  Z_single <- get_Z(example_flocker_model_single)
+  expect_true(all(Z_single >= 0))
+  expect_true(all(Z_single <= 1))
+  expect_true(any(Z_single == 1))
+
+  Z_single_C <- get_Z(example_flocker_model_single_C)
+  expect_true(all(Z_single_C >= 0))
+  expect_true(all(Z_single_C <= 1))
+  expect_true(any(Z_single_C == 1))
+
+  Z_augmented <- get_Z(example_flocker_model_aug)
+  expect_true(all(Z_augmented >= 0))
+  expect_true(all(Z_augmented <= 1))
+  expect_true(any(Z_augmented == 1))
+
+  Z_multi_colex_ex <- get_Z(example_flocker_model_multi_colex_ex)
+  expect_true(all(Z_multi_colex_ex >= 0, na.rm = T))
+  expect_true(all(Z_multi_colex_ex <= 1, na.rm = T))
+  expect_true(any(Z_multi_colex_ex == 1, na.rm = T))
+
+  Z_multi_colex_eq <- get_Z(example_flocker_model_multi_colex_eq)
+  expect_true(all(Z_multi_colex_eq >= 0, na.rm = T))
+  expect_true(all(Z_multi_colex_eq <= 1, na.rm = T))
+  expect_true(any(Z_multi_colex_eq == 1, na.rm = T))
+
+  Z_multi_auto_ex <- get_Z(example_flocker_model_multi_auto_ex)
+  expect_true(all(Z_multi_auto_ex >= 0, na.rm = T))
+  expect_true(all(Z_multi_auto_ex <= 1, na.rm = T))
+  expect_true(any(Z_multi_auto_ex == 1, na.rm = T))
+
+  Z_multi_auto_eq <- get_Z(example_flocker_model_multi_auto_eq)
+  expect_true(all(Z_multi_auto_eq >= 0, na.rm = T))
+  expect_true(all(Z_multi_auto_eq <= 1, na.rm = T))
+  expect_true(any(Z_multi_auto_eq == 1, na.rm = T))
+
+
+
+  Z_single_nohist <- get_Z(example_flocker_model_single, history_condition = FALSE)
+  expect_true(all(Z_single_nohist >= 0))
+  expect_true(all(Z_single_nohist <= 1))
+  expect_true(sum(Z_single == 1) > sum(Z_single_nohist == 1))
+
+  Z_single_C_nohist <- get_Z(example_flocker_model_single_C, history_condition = FALSE)
+  expect_true(all(Z_single_C_nohist >= 0))
+  expect_true(all(Z_single_C_nohist <= 1))
+  expect_true(sum(Z_single_C == 1) > sum(Z_single_C_nohist == 1))
+
+  Z_augmented_nohist <- get_Z(example_flocker_model_aug, history_condition = FALSE)
+  expect_true(all(Z_augmented_nohist >= 0))
+  expect_true(all(Z_augmented_nohist <= 1))
+  expect_true(sum(Z_augmented == 1) > sum(Z_augmented_nohist == 1))
+
+  Z_multi_colex_ex_nohist <- get_Z(example_flocker_model_multi_colex_ex, history_condition = FALSE)
+  expect_true(all(Z_multi_colex_ex_nohist >= 0, na.rm = T))
+  expect_true(all(Z_multi_colex_ex_nohist <= 1, na.rm = T))
+  expect_true(sum(Z_multi_colex_ex == 1, na.rm = TRUE) > sum(Z_multi_colex_ex_nohist == 1, na.rm = TRUE))
+
+  Z_multi_colex_eq_nohist <- get_Z(example_flocker_model_multi_colex_eq, history_condition = FALSE)
+  expect_true(all(Z_multi_colex_eq_nohist >= 0, na.rm = T))
+  expect_true(all(Z_multi_colex_eq_nohist <= 1, na.rm = T))
+  expect_true(sum(Z_multi_colex_eq == 1, na.rm = TRUE) > sum(Z_multi_colex_eq_nohist == 1, na.rm = TRUE))
+
+  Z_multi_auto_ex_nohist <- get_Z(example_flocker_model_multi_auto_ex, history_condition = FALSE)
+  expect_true(all(Z_multi_auto_ex_nohist >= 0, na.rm = T))
+  expect_true(all(Z_multi_auto_ex_nohist <= 1, na.rm = T))
+  expect_true(sum(Z_multi_auto_ex == 1, na.rm = TRUE) > sum(Z_multi_auto_ex_nohist == 1, na.rm = TRUE))
+
+  Z_multi_auto_eq_nohist <- get_Z(example_flocker_model_multi_auto_eq, history_condition = FALSE)
+  expect_true(all(Z_multi_auto_eq_nohist >= 0, na.rm = T))
+  expect_true(all(Z_multi_auto_eq_nohist <= 1, na.rm = T))
+  expect_true(sum(Z_multi_auto_eq == 1, na.rm = TRUE) > sum(Z_multi_auto_eq_nohist == 1, na.rm = TRUE))
+
+})
+
+
+test_that("get_Z with sampling gives valid returns", {
+  Z_single <- get_Z(example_flocker_model_single, sample = TRUE)
+  expect_true(all(Z_single %in% c(0, 1, NA)))
+
+  Z_single_C <- get_Z(example_flocker_model_single_C, sample = TRUE)
+  expect_true(all(Z_single_C %in% c(0, 1, NA)))
+
+  Z_augmented <- get_Z(example_flocker_model_aug, sample = TRUE)
+  expect_true(all(Z_augmented %in% c(0, 1, NA)))
+
+  Z_multi_colex_ex <- get_Z(example_flocker_model_multi_colex_ex, sample = TRUE)
+  expect_true(all(Z_multi_colex_ex %in% c(0, 1, NA)))
+
+  Z_multi_colex_eq <- get_Z(example_flocker_model_multi_colex_eq, sample = TRUE)
+  expect_true(all(Z_multi_colex_eq %in% c(0, 1, NA)))
+
+  Z_multi_auto_ex <- get_Z(example_flocker_model_multi_auto_ex, sample = TRUE)
+  expect_true(all(Z_multi_auto_ex %in% c(0, 1, NA)))
+
+  Z_multi_auto_eq <- get_Z(example_flocker_model_multi_auto_eq, sample = TRUE)
+  expect_true(all(Z_multi_auto_eq %in% c(0, 1, NA)))
+
+})
+
+test_that("new_data works as expected", {
+  fd1 <- simulate_flocker_data()
+  mfd1 <- make_flocker_data(fd1$obs, fd1$unit_covs, fd1$event_covs)
+  expect_silent(get_Z(example_flocker_model_single, new_data = mfd1))
+#  expect_silent(get_Z(example_flocker_model_single, history_condition = FALSE, new_data = fd1$unit_covs))
+  expect_error(get_Z(example_flocker_model_single, history_condition = TRUE, new_data = fd1$unit_covs))
+})
+
+
+test_that("incorrect types cause an error", {
+  expect_error(forward_sim("init", c(0.5, 0.5), c(0.5, 0.5)))
+  expect_error(forward_sim(0.5, "colo", c(0.5, 0.5)))
+  expect_error(forward_sim(0.5, c(0.5, 0.5), "ex"))
+})
+
+test_that("negative probabilities cause an error", {
+  expect_silent(forward_sim(.4, c(.5, .5), c(.5, .5)))
+  expect_error(forward_sim(.4, c(.5, NA), c(.5, .5)))
+  expect_error(forward_sim(-0.1, c(0.5, .5), c(0.5, .5)))
+  expect_error(forward_sim(0.5, c(.5, -0.5), c(.5, 0.5)))
+  expect_error(forward_sim(0.5, c(NA, 0.5), c(NA, -0.5)))
+})
+
+test_that("correct inputs produce correct outputs", {
+  # Simple case with no NA values and no sampling
+  expect_equal(forward_sim(0.5, c(0.5, 0.5), c(0.5, 0.5)), c(0.5, 0.5))
+  # Simple case with sampling, the result is stochastic, so we can't test exact values, just types and lengths
+  result <- forward_sim(0.5, c(0.5, 0.5), c(0.5, 0.5), sample = TRUE)
+  expect_type(result, "integer")
+  expect_length(result, 2)
+})
+
+test_that("edge cases are handled", {
+  # Case with all NA values should return NA
+  expect_error(forward_sim(NA, c(NA, NA), c(NA, NA)))
+  # Case with empty vectors
+  expect_error(forward_sim(0.5, numeric(0), numeric(0)))
+})
+
+# Test for forward_backward_algorithm function
+test_that("forward_backward_algorithm returns correct results", {
+  el0 <- c(0.1, 0.2, 0.3)
+  el1 <- c(0.9, 0.8, 0.7)
+  init <- 0.5
+  colo <- c(0.6, 0.7, 0.8)
+  ex <- c(0.4, 0.3, 0.2)
+  result <- forward_backward_algorithm(el0, el1, init, colo, ex)
+  expect_type(result, "double")
+  expect_length(result, length(el0))
+})
+
+# Test for forward_backward_sampling function
+test_that("forward_backward_sampling returns correct results", {
+  el0 <- c(0.1, 0.2, 0.3)
+  el1 <- c(0.9, 0.8, 0.7)
+  init <- 0.5
+  colo <- c(0.6, 0.7, 0.8)
+  ex <- c(0.4, 0.3, 0.2)
+  result <- forward_backward_sampling(el0, el1, init, colo, ex)
+  expect_type(result, "double")
+  expect_length(result, length(el0))
+})
+
+# Test for forward_algorithm function
+test_that("forward_algorithm returns correct results", {
+  el0 <- c(0.1, 0.2, 0.3)
+  el1 <- c(0.9, 0.8, 0.7)
+  init <- 0.5
+  colo <- c(0.6, 0.7, 0.8)
+  ex <- c(0.4, 0.3, 0.2)
+  result <- forward_algorithm(el0, el1, init, colo, ex)
+  expect_type(result, "double")
+  expect_equal(dim(result), c(length(el0), 2))
+})
+
+# Test for backward_algorithm function
+test_that("backward_algorithm returns correct results", {
+  el0 <- c(0.1, 0.2, 0.3)
+  el1 <- c(0.9, 0.8, 0.7)
+  colo <- c(0.6, 0.7, 0.8)
+  ex <- c(0.4, 0.3, 0.2)
+  result <- backward_algorithm(el0, el1, colo, ex)
+  expect_type(result, "double")
+  expect_equal(dim(result), c(length(el0), 2))
+})