Make sure all sampled populations are in the compiled model

bodkan · Dec 5, 2024 · 97abf75 · 97abf75
1 parent 5ac6a7f
commit 97abf75
Show file tree

Hide file tree

Showing 2 changed files with 43 additions and 0 deletions.
diff --git a/R/interface.R b/R/interface.R
@@ -1257,6 +1257,13 @@ schedule_sampling <- function(model, times, ..., locations = NULL, strict = FALS
   sample_pops <- purrr::map(samples, 1)
   sample_counts <- purrr::map(samples, 2)
 
+  model_names <- vapply(model$populations, function(pop) pop$pop[1], FUN.VALUE = "character")
+  sample_names <- vapply(sample_pops, function(pop) pop$pop[1], FUN.VALUE = "character")
+  missing_names <- setdiff(sample_names, model_names)
+  if (length(missing_names))
+    stop("The following sampled populations are not part of the model: ",
+         paste(missing_names, collapse = ", "), call. = FALSE)
+
   if (is.null(model$world) && !is.null(locations))
     stop("Sampling locations may only be specified for a spatial model", call. = FALSE)
 

diff --git a/tests/testthat/test-sampling.R b/tests/testthat/test-sampling.R
@@ -319,3 +319,39 @@ test_that("sampling table is correctly adjusted after simplification (SLiM)", {
   expect_true(nrow(ts_samples(ts_small2_model)) == 4)
   expect_error(ts_samples(ts_small2_nomodel), "Sampling schedule can only be extracted")
 })
+
+test_that("all sampled populations must be present in the compiled model", {
+  pA <- population("pA", time = 1, N = 1000)
+  pB <- population("pB", time = 300, N = 1000, parent = pA)
+  pC <- population("pC", time = 600, N = 1000, parent = pB)
+  pD <- population("pD", time = 800, N = 1000, parent = pA)
+  pE <- population("pE", time = 1300, N = 1000, parent = pC)
+
+  model <- compile_model(list(pA, pB, pC, pD, pE), generation_time = 1, simulation_length = 2000)
+
+  p1 <- population("p1", time = 1, N = 1000)
+  p2 <- population("p2", time = 300, N = 1000, parent = p1)
+  p3 <- population("p3", time = 600, N = 1000, parent = p2)
+  p4 <- population("p4", time = 800, N = 1000, parent = p1)
+  p5 <- population("p5", time = 1300, N = 1000, parent = p4)
+
+  expect_error(
+    schedule_sampling(model, times = 2000, list(p1, 10), list(p2, 10), list(p3, 10), list(p4, 10), list(p5, 10)),
+    "The following sampled populations are not part of the model: p1, p2, p3, p4, p5"
+  )
+
+  expect_error(
+    schedule_sampling(model, times = 2000, list(pA, 10), list(p2, 10), list(pC, 10), list(p4, 10), list(pD, 10)),
+    "The following sampled populations are not part of the model: p2, p4"
+  )
+
+  expect_error(
+    schedule_sampling(model, times = 2000, list(pA, 10), list(pB, 10), list(pC, 10), list(p4, 10), list(pD, 10)),
+    "The following sampled populations are not part of the model: p4"
+  )
+
+  expect_s3_class(
+    schedule_sampling(model, times = 2000, list(pA, 10), list(pB, 10), list(pC, 10), list(pD, 10), list(pD, 10)),
+    "data.frame"
+  )
+})