tests/testthat/test_kinshipMatricesToKValues.R

In nprcgenekeepr: Genetic Tools for Colony Management

#' Copyright(c) 2017-2023 R. Mark Sharp
#' This file is part of nprcgenekeepr
library(testthat)
context("kinshipMatricesToKValues")

ped <- nprcgenekeepr::smallPed
# nolint start: object_name_linter.
simParent_1 <- list(
  id = "A",
  sires = c("s1_1", "s1_2", "s1_3"),
  dams = c("d1_1", "d1_2", "d1_3", "d1_4")
)
simParent_2 <- list(
  id = "B",
  sires = c("s1_1", "s1_2", "s1_3"),
  dams = c("d1_1", "d1_2", "d1_3", "d1_4")
)
simParent_3 <- list(
  id = "E",
  sires = c("A", "C", "s1_1"),
  dams = c("d3_1", "B")
)
simParent_4 <- list(
  id = "J",
  sires = c("A", "C", "s1_1"),
  dams = c("d3_1", "B")
)
simParent_5 <- list(
  id = "K",
  sires = c("A", "C", "s1_1"),
  dams = c("d3_1", "B")
)
simParent_6 <- list(
  id = "N",
  sires = c("A", "C", "s1_1"),
  dams = c("d3_1", "B")
)
allSimParents <- list(
  simParent_1, simParent_2, simParent_3,
  simParent_4, simParent_5, simParent_6
)

extractKinship <- function(simKinships, id1, id2, simulation) {
  ids <- dimnames(simKinships[[simulation]])[[1L]]
  simKinships[[simulation]][
    seq_along(ids)[ids == id1],
    seq_along(ids)[ids == id2]
  ]
}

extractKValue <- function(kValue, id1, id2, simulation) {
  # nolint start: object_usage_linter.
  kValue[id_1 == id1 & id_2 == id2, paste0("sim_", simulation),
    with = FALSE
  ][[1L]]
  # nolint end: object_usage_linter.
}
# nolint end: object_usage_linter.
set_seed(seed = 1L)
n <- 10L
pop <- ped$id
nPop <- length(pop)
expectedNRows <- nPop + nPop * (nPop - 1L) / 2L
expectedNCols <- 2L + n
simKinships <- createSimKinships(ped, allSimParents, pop = pop, n = n)
kValue <- kinshipMatricesToKValues(simKinships)
test_that("kinshipMatricesToKValues gets correct number of rows", {
  expect_equal(nrow(kValue), expectedNRows)
})
test_that("kinshipMatricesToKValues gets correct number of columns", {
  expect_length(kValue, expectedNCols)
})

test_that("kinshipMatricesToKValues gets correct kinship values", {
  expect_identical(
    extractKinship(simKinships, "A", "B", 2L),
    extractKValue(kValue, id1 = "A", id2 = "B", simulation = 2L)
  )
  expect_identical(
    extractKinship(simKinships, "A", "C", 2L),
    extractKValue(kValue, id1 = "A", id2 = "C", simulation = 2L)
  )
  expect_identical(
    extractKinship(simKinships, "A", "D", 2L),
    extractKValue(kValue, id1 = "A", id2 = "D", simulation = 2L)
  )
  expect_identical(
    extractKinship(simKinships, "A", "E", 2L),
    extractKValue(kValue, id1 = "A", id2 = "E", simulation = 2L)
  )
  expect_identical(
    extractKinship(simKinships, "A", "B", 3L),
    extractKValue(kValue, id1 = "A", id2 = "B", simulation = 3L)
  )
})