tests/testthat/test-impossible.R

In segtest: Tests for Segregation Distortion in Polyploids

test_that("impossible genotypes calculated correctly", {
  xmat <- structure(
    c(
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1,
      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
      2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4,
      4, 4, 4, 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
      0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2,
      2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 5, 0, 0, 0,
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1,
      1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
      1, 1, 1, 1, 1, 1, 2, 2, 2, 3, 0, 0, 0, 0, 0, 0, 1, 1, 1, 2, 0,
      0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3,
      3, 4, 4, 5, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 3, 3, 4, 0, 0,
      0, 0, 1, 1, 1, 2, 2, 3, 0, 0, 0, 1, 1, 2, 0, 0, 1, 0, 0, 0, 0,
      0, 0, 1, 1, 1, 1, 2, 2, 2, 3, 3, 4, 0, 0, 0, 0, 1, 1, 1, 2, 2,
      3, 0, 0, 0, 1, 1, 2, 0, 0, 1, 0, 0, 0, 0, 0, 1, 1, 1, 2, 2, 3,
      0, 0, 0, 1, 1, 2, 0, 0, 1, 0, 0, 0, 0, 1, 1, 2, 0, 0, 1, 0, 0,
      0, 1, 0, 0, 0, 1, 2, 3, 4, 5, 0, 1, 2, 3, 4, 0, 1, 2, 3, 0, 1,
      2, 0, 1, 0, 0, 1, 2, 3, 4, 0, 1, 2, 3, 0, 1, 2, 0, 1, 0, 0, 1,
      2, 3, 0, 1, 2, 0, 1, 0, 0, 1, 2, 0, 1, 0, 0, 1, 0, 0, 0, 1, 2,
      3, 4, 0, 1, 2, 3, 0, 1, 2, 0, 1, 0, 0, 1, 2, 3, 0, 1, 2, 0, 1,
      0, 0, 1, 2, 0, 1, 0, 0, 1, 0, 0, 0, 1, 2, 3, 0, 1, 2, 0, 1, 0,
      0, 1, 2, 0, 1, 0, 0, 1, 0, 0, 0, 1, 2, 0, 1, 0, 0, 1, 0, 0, 0,
      1, 0, 0, 0, 5, 4, 3, 2, 1, 0, 4, 3, 2, 1, 0, 3, 2, 1, 0, 2, 1,
      0, 1, 0, 0, 4, 3, 2, 1, 0, 3, 2, 1, 0, 2, 1, 0, 1, 0, 0, 3, 2,
      1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 0, 1, 0, 0, 1, 0, 0, 0, 4, 3, 2,
      1, 0, 3, 2, 1, 0, 2, 1, 0, 1, 0, 0, 3, 2, 1, 0, 2, 1, 0, 1, 0,
      0, 2, 1, 0, 1, 0, 0, 1, 0, 0, 0, 3, 2, 1, 0, 2, 1, 0, 1, 0, 0,
      2, 1, 0, 1, 0, 0, 1, 0, 0, 0, 2, 1, 0, 1, 0, 0, 1, 0, 0, 0, 1,
      0, 0, 0, 0), dim = c(126L, 5L), dimnames = list(NULL, NULL))

  pdf <- expand.grid(p1 = 0:4, p2 = 0:4, dr = c(TRUE, FALSE))

  TOL <- sqrt(.Machine$double.eps)
  for (i in seq_len(nrow(pdf))) {
    gf <- offspring_gf_2(
      alpha = ifelse(pdf$dr[[i]], 1/6, 0),
      xi1 = 1/3,
      xi2 = 1/3,
      p1 = pdf$p1[[i]],
      p2 = pdf$p2[[i]])

    if (any(gf < TOL)) {
      which_0 <- gf < TOL
      for (j in seq_len(nrow(xmat))) {
        if (!all(xmat[j, which_0] == 0)) {
          expect_true(is_impossible(x = xmat[j, ], g1 = pdf$p1[[i]], g2 = pdf$p2[[i]], dr = pdf$dr[[i]]))
        } else {
          expect_false(is_impossible(x = xmat[j, ], g1 = pdf$p1[[i]], g2 = pdf$p2[[i]], dr = pdf$dr[[i]]))
        }
      }
    } else {
      expect_false(is_impossible(x = xmat[j, ], g1 = pdf$p1[[i]], g2 = pdf$p2[[i]], dr = pdf$dr[[i]]))
    }
  }
})


test_that("is_valid_2() works", {
  expect_true(is_valid_2(dr = 1/6, pp = 1/3, drbound = 1/6))
  expect_false(is_valid_2(dr = 1/6, pp = 1/3 - 1e-6, drbound = 1/6))
  expect_false(is_valid_2(dr = 1/6, pp = 1/3 + 1e-6, drbound = 1/6))
  expect_true(is_valid_2(dr = 0, pp = 0, drbound = 1/6))
  expect_true(is_valid_2(dr = 0, pp = 1, drbound = 1/6))
})

test_that("three and two equal", {
  tau <- 1/2
  beta <- 1/6
  gamma <- 1/3
  ell <- 2
  p3 <- pvec_tet_3(tau = tau, beta = beta, gamma = gamma, ell = ell)
  par <- three_to_two(tau = tau, beta = beta, gamma = gamma)
  alpha <- par[[1]]
  xi <- par[[2]]
  p2 <- pvec_tet_2(alpha = alpha, xi = xi, ell = ell)
  expect_equal(p2, p3)
})