Make sure parent is not removed before daughter splits

bodkan · Jun 14, 2023 · 0791b57 · 0791b57
1 parent cbe7781
commit 0791b57
Show file tree

Hide file tree

Showing 3 changed files with 47 additions and 1 deletion.
diff --git a/R/interface.R b/R/interface.R
@@ -79,6 +79,15 @@ population <- function(name, time, N, parent = NULL, map = FALSE,
       check_split_time(time, parent)
   }
 
+  parent_remove <- attr(parent, "remove")
+  if (!is.null(parent) && parent_remove != -1) {
+    direction <- if (time > parent$time) "forward" else "backward"
+    if (direction == "forward" && parent_remove <= time)
+      stop("Parent population will be removed before the split event", call. = FALSE)
+    else if (direction == "backward" && parent_remove >= time)
+      stop("Parent population will be removed before the split event", call. = FALSE)
+  }
+
   if (!is.logical(map) && !inherits(map, "slendr_map"))
     stop("A simulation landscape must be an object of the class slendr_map", call. = FALSE)
 

diff --git a/tests/testthat/test-geneflow.R b/tests/testthat/test-geneflow.R
@@ -81,7 +81,7 @@ test_that("populations must be already created for a gene flow to happen (forwar
 # that the issue has been solved
 # https://github.com/bodkan/slendr/issues/132
 test_that("gene_flow() behaves as expected in some concrete situations", {
-  anc <- population("ancestor", time = 9e6, remove=8e6, N=100)
+  anc <- population("ancestor", time = 9e6, remove=6e6, N=100)
   popA <- population("A", time = 8e6, parent=anc, N=100)
   popB <- population("B", time = 7e6, parent=anc, N=100)
 

diff --git a/tests/testthat/test-population.R b/tests/testthat/test-population.R
@@ -23,6 +23,43 @@ test_that("non-integer population split time is rounded", {
   expect_true(attr(pop, "history")[[1]]$N == 101)
 })
 
+test_that("parent cannot be scheduled for removal before a daughter splits (forward)", {
+  error_msg <- "Parent population will be removed"
+
+  parent <- population("parent", time = 1, N = 1, remove = 50)
+  expect_error(population("daughter", time = 100, N = 1, parent = parent), error_msg)
+  expect_error(population("daughter", time = 50, N = 1, parent = parent), error_msg)
+  expect_s3_class(population("daughter", time = 30, N = 1, parent = parent), "slendr_pop")
+
+  parent <- population("parent", time = 100, N = 1, remove = 150)
+  expect_error(population("daughter", time = 200, N = 1, parent = parent), error_msg)
+  expect_error(population("daughter", time = 150, N = 1, parent = parent), error_msg)
+  expect_s3_class(daughter <- population("daughter", time = 120, N = 1, parent = parent), "slendr_pop")
+
+  model <- compile_model(list(parent, daughter), simulation_length = 300, generation_time = 10)
+
+  # successful model definition in slendr is one thing, but let's make sure the
+  # simulation themselves really run
+  expect_s3_class(slim(model, sequence_length = 1, recombination_rate = 0), "slendr_ts")
+  expect_s3_class(msprime(model, sequence_length = 1, recombination_rate = 0), "slendr_ts")
+})
+
+test_that("parent cannot be scheduled for removal before a daughter splits (backward)", {
+  error_msg <- "Parent population will be removed"
+
+  parent <- population("parent", time = 1000, N = 1, remove = 500)
+  expect_error(population("daughter", time = 100, N = 1, parent = parent), error_msg)
+  expect_error(population("daughter", time = 500, N = 1, parent = parent), error_msg)
+  expect_s3_class(daughter <- population("daughter", time = 800, N = 1, parent = parent), "slendr_pop")
+
+  model <- compile_model(list(parent, daughter), generation_time = 10)
+
+  # successful model definition in slendr is one thing, but let's make sure the
+  # simulation themselves really run
+  expect_s3_class(slim(model, sequence_length = 1, recombination_rate = 0), "slendr_ts")
+  expect_s3_class(msprime(model, sequence_length = 1, recombination_rate = 0), "slendr_ts")
+})
+
 #
 # population resizes (step)
 #