tests/testthat/test-pedhalflife.R

In visPedigree: Tidying, Analysis, and Fast Visualization of Animal and Plant Pedigrees

test_that("pedhalflife returns correct structure", {
  data(simple_ped)
  tped <- suppressMessages(tidyped(simple_ped))

  res <- suppressMessages(
    suppressWarnings(pedhalflife(tped, timevar = "Gen"))
  )

  # Class and top-level components

  expect_s3_class(res, "pedhalflife")
  expect_true("timeseries" %in% names(res))
  expect_true("decay" %in% names(res))

  # Timeseries columns
  ts <- res$timeseries
  expect_s3_class(ts, "data.table")
  expect_true(all(c("Time", "NRef", "fe", "fa", "fg",
                     "lnfe", "lnfa", "lnfg", "lnfafe", "lnfgfa",
                     "TimeStep") %in% names(ts)))
  expect_true(nrow(ts) >= 2)

  # Decay columns
  d <- res$decay
  expect_s3_class(d, "data.table")
  expect_true(all(c("LambdaE", "LambdaB", "LambdaD",
                     "LambdaTotal", "THalf") %in% names(d)))
  expect_equal(nrow(d), 1L)
})


test_that("lambda decomposition sums correctly (OLS linearity)", {
  data(simple_ped)
  tped <- suppressMessages(tidyped(simple_ped))

  res <- suppressMessages(
    suppressWarnings(pedhalflife(tped, timevar = "Gen"))
  )
  d <- res$decay

  # By linearity of least squares, lambda_total == lambda_e + lambda_b + lambda_d
  if (!is.na(d$LambdaTotal)) {
    expect_equal(d$LambdaTotal,
                 d$LambdaE + d$LambdaB + d$LambdaD,
                 tolerance = 1e-10)
  }

  # THalf identity
  if (!is.na(d$THalf) && d$LambdaTotal > 0) {
    expect_equal(d$THalf, log(2) / d$LambdaTotal, tolerance = 1e-10)
  }
})


test_that("log columns are consistent with raw values", {
  data(simple_ped)
  tped <- suppressMessages(tidyped(simple_ped))

  res <- suppressMessages(
    suppressWarnings(pedhalflife(tped, timevar = "Gen"))
  )
  ts <- res$timeseries

  expect_equal(ts$lnfe, log(ts$fe), tolerance = 1e-12)
  expect_equal(ts$lnfa, log(ts$fa), tolerance = 1e-12)
  expect_equal(ts$lnfg, log(ts$fg), tolerance = 1e-12)
  expect_equal(ts$lnfafe, log(ts$fa / ts$fe), tolerance = 1e-12)
  expect_equal(ts$lnfgfa, log(ts$fg / ts$fa), tolerance = 1e-12)
})


test_that("pedhalflife rejects invalid inputs", {
  data(simple_ped)
  tped <- suppressMessages(tidyped(simple_ped))

  # Missing column
  expect_error(pedhalflife(tped, timevar = "NoSuchCol"),
               "Column 'NoSuchCol' not found")

  # Single time point
  tped2 <- data.table::copy(tped)
  tped2$Year <- 2000
  expect_error(suppressMessages(pedhalflife(tped2, timevar = "Year")),
               "At least two distinct")
})


test_that("print and plot methods work without error", {
  data(simple_ped)
  tped <- suppressMessages(tidyped(simple_ped))

  res <- suppressMessages(
    suppressWarnings(pedhalflife(tped, timevar = "Gen"))
  )

  # print returns invisible x
  out <- capture.output(ret <- print(res))
  expect_identical(ret, res)
  expect_true(length(out) > 0)

  # plot returns a lattice trellis object
  p <- plot(res, type = "log")
  expect_s3_class(p, "trellis")

  p2 <- plot(res, type = "raw")
  expect_s3_class(p2, "trellis")
})