tests/testthat/test-sims.R

In magnusdv/forrel: Forensic Pedigree Analysis and Relatedness Inference

mSim = function(...) markerSim(..., verbose = FALSE)
pSim = function(...) profileSim(..., numCores = 1, verbose = FALSE)
sSim = function(...) simpleSim(..., verbose = FALSE)

test_that("simpleSim() runs in trivial example", {
  x = nuclearPed(1)
  y = sSim(x, N=1, alleles=1:2)
  expect_is(y, "ped")
  expect_equal(nMarkers(y), 1)
  expect_true(all(y$MARKERS[[1]] > 0))
})

test_that("simpleSim() works with explicit mutation args", {
  x = nuclearPed(1)
  mut = structure(c(0, 0, 1, 1), dim = c(2L, 2L), dimnames = list(c("1", "2"), c("1", "2")),
                  model = "custom", class = "mutationMatrix")
  mod = structure(list(female = mut, male = mut), sexEqual = TRUE,
                  alwaysLumpable = TRUE, class = "mutationModel")
  y = sSim(x, N=1, alleles = 1:2, afreq = c(.99, .01), mutmod = mod)
  expect_equal(genotype(y, 1, id=3), c("2", "2"))
})

test_that("markerSim() runs in simple example", {
  x = nuclearPed(1)
  m = marker(x, '3'=1, alleles=1:2)
  y = mSim(x, N=1, partialmarker=m)
  expect_is(y, "ped")
  expect_equal(nMarkers(y), 1)
  expect_equal(genotype(y, 1, id=3), c("1", "1"))
  expect_true(all(y$MARKERS[[1]] > 0))
})

test_that("markerSim() works with partial with mutations", {
  x = nuclearPed(1)
  m = marker(x, '1'=1, '2'=1, alleles=1:2, mutmod = "eq", rate=1)
  y = mSim(x, N=1, partialmarker=m)
  expect_equal(genotype(y, 1, id=3), c("2", "2"))
})

test_that("profileSim() keeps marker names", {
  x = nuclearPed(1)
  m = marker(x)
  x = setMarkers(x, list(m, m))
  name(x, 1:2) = c("m1", "m2")

  s = pSim(x, N = 1)
  expect_identical(name(s, 1:2), c("m1", "m2"))

  s2 = pSim(x, N = 1, markers = list(m, m))
  expect_identical(name(s2, 1:2), rep(NA_character_, 2))
})

test_that("profileSim() treats pedlists as expected", {
  x = singleton(1) |> addMarker(alleles = 1:5, name = "M")
  y = relabel(x, 2)
  SEED = 777

  sim_pedlist = pSim(list(x, y), N = 3, markers = "M", seed = SEED)

  set.seed(SEED)
  sim_compwise = list(pSim(x, N = 3, markers = "M"),
                      pSim(y, N = 3, markers = "M"))

  # Check third sim
  expect_identical(sim_pedlist[[3]], lapply(sim_compwise, `[[`, 3))
})

test_that("markerSim() works with peds in non-standard ordering", {
x = reorderPed(nuclearPed(2), 4:1)
m = marker(x, "3" = 1, "4" = 2) # parents must be 1:2

y = mSim(x, partialmarker = m)
expect_identical(genotype(y, id = 1, marker = 1), c("1", "2"))
})

test_that("markerSim() works in looped pedigree 1", {
  x = linearPed(2) |> addSon(c(2,5)) |>
    addMarker("5" = "1/1", alleles = 1:2, afreq = c(0.001, 0.999))

  y = mSim(x, partialmarker = 1, seed = 123)
  expect_identical(genotype(y, id = 3, marker = 1), c("1", "2"))
  expect_identical(genotype(y, id = 4, marker = 1), c("1", "2"))
})

test_that("markerSim() works in looped pedigree 2", {
  x = linearPed(2) |> addSon(c(2,5)) |> addMarker("6" = "1/1", "2" = "0/2")
  # plot(x, mark =1)

  y1 = mSim(x, partialmarker = 1)
  expect_identical(genotype(y1, id = 2, marker = 1), c("1", "2")) # Forced

  x2 = x |> addParents(2, 10, 11, verbose = FALSE) |> addMarker("6" = 1, "10" = 2)
  # plot(x2, mark = 2)

  y2 = mSim(x2, partialmarker = 2)
  expect_identical(genotype(y2, id = 2, marker = 1), c("1", "2")) # Forced!

  y3 = mSim(x2, partialmarker = 2, loopBreaker = "5")
  expect_identical(genotype(y3, id = 2, marker = 1), c("1", "2")) # Forced!
})

test_that("markerSim() works in looped pedigree 3", {
  x = cousinPed(0, child = T) |> relabel(new = letters[1:5]) |> addMarker(c = 1:2)

  y1 = mSim(x, partial = 1, loopBreaker = "c", seed = 1234)
  expect_equal(as.numeric(getAlleles(y1)), c(1,2,1,2,1,2,2,2,2,2))

  y2 = mSim(x, partial = 1, loopBreaker = "d", seed = 1234)
  expect_equal(as.numeric(getAlleles(y2)), c(2,1,1,1,1,2,1,2,2,2))
})