tests/testthat/test_inbreeding.R

In purgeR: Inbreeding-Purging Estimation in Pedigreed Populations

library(purgeR)
context("Inbreeding coefficients")

data(atlas)
data(arrui)
atlas_F <- purgeR::ip_F(atlas)
testthat::test_that("Standard inbreeding", {
  testthat::expect_equal(base::ncol(atlas), 10)
  testthat::expect_equal(base::ncol(atlas_F), 11)
  testthat::expect_equal(base::colnames(atlas_F)[length(atlas_F)], "Fi")
  testthat::expect_equal(base::min(atlas_F$F), 0.0, tolerance = 1e-5)
  testthat::expect_equal(base::max(atlas_F$F), 0.4277344, tolerance = 1e-5)
  testthat::expect_equal(utils::tail(atlas_F$F, n = 1), 0.2345642, tolerance = 1e-5)
  testthat::expect_equal(base::sum(atlas_F$F), 197.2809, tolerance = 1e-5)
  testthat::expect_warning(purgeR::ip_F(atlas_F))
  ped_selfing <- data.frame(id = c(1L, 2L, 3L, 4L), dam = c(0L, 1L, 2L, 3L), sire = c(0L, 1L, 2L, 3L))
  ped_selfing <- ip_F(ped_selfing)
  testthat::expect_equal(ped_selfing$F, c(0.0, 0.5, 0.75, 0.875), tolerance = 1e-5)
})

testthat::test_that("Ancestral inbreeding", {
  atlas_Fa <- purgeR::ip_Fa(atlas)
  testthat::expect_equal(base::ncol(atlas_Fa), 11)
  testthat::expect_equal(base::colnames(atlas_Fa)[length(atlas_Fa)], "Fa")
  testthat::expect_equal(base::min(atlas_Fa$Fa), 0.0, tolerance = 1e-5)
  testthat::expect_equal(base::max(atlas_Fa$Fa), 0.8314975, tolerance = 1e-5)
  testthat::expect_equal(utils::tail(atlas_Fa$Fa, n = 1), 0.7774758, tolerance = 1e-5)
  testthat::expect_equal(base::sum(atlas_Fa$Fa), 445.3923, tolerance = 1e-5)
  atlas_Fa <- purgeR::ip_Fa(atlas, genedrop = 100, seed = 1234)
  testthat::expect_equal(base::max(atlas_Fa$Fa), 0.71, tolerance = 1e-5)
  testthat::expect_equal(utils::tail(atlas_Fa$Fa, n = 1), 0.610, tolerance = 1e-5)
  testthat::expect_equal(base::sum(atlas_Fa$Fa), 356.4, tolerance = 1e-5)
})

testthat::test_that("Maternal inbreeding", {
  atlas_maternal <- purgeR::ped_maternal(atlas_F, value_from = 'Fi', name_to = 'Fdam')
  testthat::expect_equal(base::ncol(atlas_maternal), 12)
  testthat::expect_equal(base::colnames(atlas_maternal)[length(atlas_maternal)], "Fdam")
  testthat::expect_equal(base::max(atlas_maternal$Fdam, na.rm = TRUE), 0.4226761, tolerance = 1e-5)
  testthat::expect_equal(utils::tail(atlas_maternal$Fdam, n = 1), 0.2566822, tolerance = 1e-5)
  testthat::expect_equal(base::sum(atlas_maternal$Fdam, na.rm = TRUE), 169.3187, tolerance = 1e-5)
  atlas_paternal <- purgeR::ped_maternal(atlas_F, value_from = 'Fi', name_to = 'Fsire', use_dam = FALSE)
  testthat::expect_equal(base::max(atlas_paternal$Fsire, na.rm = TRUE), 0.34375, tolerance = 1e-5)
  testthat::expect_equal(utils::tail(atlas_paternal$Fsire, n = 1), 0.2088947, tolerance = 1e-5)
  testthat::expect_equal(base::sum(atlas_paternal$Fsire, na.rm = TRUE), 156.2475, tolerance = 1e-5)
})

testthat::test_that("Partial inbreeding", {
  atlas50 <- head(atlas, n = 50)
  atlas_Fij <- purgeR::ip_Fij(atlas50)
  testthat::expect_equal(base::dim(atlas_Fij), c(50, 4))
  testthat::expect_equal(atlas_Fij[[50, 1]], 0.1875, tolerance = 1e-5)
  testthat::expect_equal(atlas_Fij[[50, 2]], 0.0, tolerance = 1e-5)
  testthat::expect_equal(atlas_Fij[[48, 1]], 0.125, tolerance = 1e-5)
  testthat::expect_equal(atlas_Fij[[48, 2]], 0.125, tolerance = 1e-5)
  testthat::expect_equal(base::sum(atlas_Fij[,1]), 4.3125, tolerance = 1e-5)
  testthat::expect_equal(base::sum(atlas_Fij[,2]), 1.8125, tolerance = 1e-5)
  atlas_Fij_all <- purgeR::ip_Fij(atlas50,  mode = "all")
  testthat::expect_equal(base::dim(atlas_Fij_all), c(50, 50))
  testthat::expect_equal(base::sum(atlas_Fij_all), base::sum(atlas_Fij), tolerance = 1e-5)
  arrui50 <- head(arrui, n = 50)
  arrui_Fij <- purgeR::ip_Fij(arrui50)
  arrui_Fij_all <- purgeR::ip_Fij(arrui50, mode = "all")
  testthat::expect_equal(base::sum(arrui_Fij), 16.125, tolerance = 1e-5)
  testthat::expect_equal(base::sum(arrui_Fij_all), 22.6875, tolerance = 1e-5)
  anc <- base::as.integer(c(2,6))
  arrui_Fij_custom <- purgeR::ip_Fij(arrui50, mode = "custom", ancestors =  anc)
  testthat::expect_equal(arrui_Fij_custom[, 1], arrui_Fij_all[, 2], tolerance = 1e-5)
  testthat::expect_equal(arrui_Fij_custom[, 2], arrui_Fij_all[, 6], tolerance = 1e-5)
  arrui_Fij_custom_2cores <- purgeR::ip_Fij(arrui50, mode = "custom", ancestors =  anc, ncores = 2)
  testthat::expect_equal(arrui_Fij_custom, arrui_Fij_custom_2cores, tolerance = 1e-5, check.attributes = FALSE)
  testthat::expect_equal(base::dim(arrui_Fij_custom), base::dim(arrui_Fij_custom_2cores))
  atlas_Fij_genedrop <- purgeR::ip_Fij(atlas50, genedrop = 1000, seed = 1234)
  testthat::expect_equal(atlas_Fij_genedrop[[50, 1]], 0.183, tolerance = 1e-5)
  testthat::expect_equal(atlas_Fij_genedrop[[50, 2]], 0.0, tolerance = 1e-5)
  testthat::expect_equal(atlas_Fij_genedrop[[48, 1]], 0.128, tolerance = 1e-5)
  testthat::expect_equal(atlas_Fij_genedrop[[48, 2]], 0.107, tolerance = 1e-5)
  testthat::expect_equal(base::sum(atlas_Fij_genedrop[,1]), 4.341, tolerance = 1e-5)
  testthat::expect_equal(base::sum(atlas_Fij_genedrop[,2]), 1.807, tolerance = 1e-5)
})

testthat::test_that("Purged inbreeding", {
  atlas_g <- purgeR::ip_g(atlas, d = 0.0)
  testthat::expect_equal(atlas_g$g0, atlas_F$Fi, tolerance = 1e-5)
  atlas_g <- purgeR::ip_g(atlas, d = 0.5)
  testthat::expect_equal(base::max(atlas_g$g0.5), 0.3028946, tolerance = 1e-5)
  testthat::expect_equal(utils::tail(atlas_g$g0.5, n = 1), 0.05987971, tolerance = 1e-5)
  testthat::expect_equal(base::sum(atlas_g$g0.5), 104.5671, tolerance = 1e-5)
})

testthat::test_that("Opportunity of purging", {
  gulisija <- tibble::tibble(
    id = c("M", "K", "J", "a", "c", "b", "e", "d", "I"),
    dam = c("0", "0", "0", "K", "M", "a", "c", "c", "e"),
    sire = c("0", "0", "0", "J", "a", "J", "b", "b", "d")
  )
  # return error if use op() now
  gulisija <- purgeR::ped_rename(gulisija, keep_names = TRUE)
  gulisija <- purgeR::ip_F(gulisija)
  gulisija <- purgeR::ip_op(gulisija, Fcol = "Fi", compute_O = TRUE)
  gulisija_Fij <- purgeR::ip_Fij(gulisija, Fcol = "Fi")
  testthat::expect_equal(gulisija$Fi, base::rowSums(gulisija_Fij), tolerance = 1e-5)
  testthat::expect_equal(gulisija_Fij[[9, 1]], 0.0625, tolerance = 1e-5)
  testthat::expect_equal(gulisija_Fij[[9, 2]], 0.09375, tolerance = 1e-5)
  testthat::expect_equal(gulisija_Fij[[9, 3]], 0.21875, tolerance = 1e-5)
  testthat::expect_equal(gulisija$O[8], 0.125, tolerance = 1e-5)
  testthat::expect_equal(gulisija$O[9], 0.3125, tolerance = 1e-5)
  testthat::expect_equal(base::sum(gulisija$O), 0.5625, tolerance = 1e-5)
  testthat::expect_equal(gulisija$Oe[9], 0.0625, tolerance = 1e-5)
  testthat::expect_equal(base::sum(gulisija$Oe), 0.0625, tolerance = 1e-5)
  arrui_op <- ip_op(arrui, compute_O = TRUE)
  testthat::expect_equal(sum(arrui_op$O), 259.3293, tolerance = 1e-5)
  testthat::expect_equal(sum(arrui_op$O_raw), 310.843, tolerance = 1e-5)
  testthat::expect_equal(sum(arrui_op$Oe), 31.44434, tolerance = 1e-5)
  testthat::expect_equal(sum(arrui_op$Oe_raw), 34.47632, tolerance = 1e-5)
  testthat::expect_equal(arrui_op[370, ]$O, 1.169922, tolerance = 1e-5)
  testthat::expect_equal(arrui_op[370, ]$O_raw, 2.029297, tolerance = 1e-5)
  testthat::expect_equal(arrui_op[370, ]$Oe, 0.8193359, tolerance = 1e-5)
  testthat::expect_equal(arrui_op[370, ]$Oe_raw, 0.9316406, tolerance = 1e-5)
})

testthat::test_that("Call to precomputed inbreeding values", {
  testthat::expect_warning(purgeR::ip_F(atlas_F))
  testthat::expect_error(purgeR::ip_Fa(atlas_F, Fcol = "pom"), "Inbreeding needs to be of numeric type")
  testthat::expect_error(purgeR::ip_Fa(atlas_F, Fcol = "prod"))
})