tests/testthat/test-calcCoordinates.R

In ggpedigree: Visualizing Pedigrees with 'ggplot2' and 'plotly'

test_that("calculateCoordinates assigns correct layout for unique individuals", {
  library(BGmisc)
  data("potter")

  ped <- potter

  coords <- calculateCoordinates(ped, code_male = 1, personID = "personID")

  expect_true(all(c("x_order", "y_order", "x_pos", "y_pos", "nid") %in% names(coords)))
  expect_true(all(ped$ID %in% coords$personID)) # ID retention
  expect_equal(nrow(coords), nrow(ped)) # no duplicates yet
})

# test_that("calculateCoordinates extras", {
#  library(BGmisc)
#  data("ASOIAF")

# coords <- calculateCoordinates(ASOIAF, code_male = "M", personID = "id")

# expect_true("extra" %in% names(coords))
# dup_ids <- coords$ID[duplicated(coords$ID)]
# expect_true(length(dup_ids) > 0)  # Someone appears twice
# expect_true(any(coords$extra == TRUE))
# })
test_that("calculateCoordinates Code M works for characters", {
  ped <- data.frame(
    ID = c("A", "B", "C", "D", "X"),
    momID = c(NA, "A", "A", "C", NA),
    dadID = c(NA, "X", "X", "B", NA),
    spouseID = c("X", "C", "B", NA, "A"),
    sex = c("F", "M", "F", "F", "M")
  )

  coords <- calculateCoordinates(ped,
    code_male = "M", personID = "ID",
    spouseID = "spouseID"
  )

  expect_true(all(c("x_order", "y_order", "x_pos", "y_pos", "nid") %in% names(coords)))
  expect_true(all(coords$ID %in% ped$ID)) # ID retention
  expect_equal(nrow(coords), nrow(ped)) # no duplicates yet
})


test_that("calculateConnections returns expected structure", {
  ped <- data.frame(
    personID = c("A", "B", "C", "D", "X"),
    momID = c(NA, "A", "A", "C", NA),
    dadID = c(NA, "X", "X", "B", NA),
    spouseID = c("X", "C", "B", NA, "A"),
    sex = c("F", "M", "F", "F", "M")
  )

  coords <- calculateCoordinates(ped, code_male = "M", personID = "personID")
  conns <- calculateConnections(coords, config = list(code_male = "M"))

  expected_cols <- c(
    "personID", "x_pos", "y_pos",
    "dadID", "momID", "spouseID",
    "x_mom", "y_mom", "x_dad", "y_dad",
    "x_spouse", "y_spouse",
    #   "x_midparent", "y_midparent",
    "x_mid_spouse", "y_mid_spouse",
    "x_mid_sib", "y_mid_sib"
  )

  expect_true(all(expected_cols %in% names(conns$connections)))
})


test_that("getRelativeCoordinates returns expected coordinates for mother", {
  # Step 1: Minimal input pedigree
  input_ped <- data.frame(
    personID = c("A", "B", "C", "D"),
    momID = c(NA, NA, "A", "A"),
    dadID = c(NA, NA, "B", "B"),
    spouseID = c("B", "A", NA, NA),
    sex = c("F", "M", "F", "M"),
    stringsAsFactors = FALSE
  )

  # Step 2: Apply calculateCoordinates (required precondition)
  ped <- calculateCoordinates(
    input_ped,
    personID = "personID",
    momID = "momID",
    dadID = "dadID",
    spouseID = "spouseID",
    sexVar = "sex",
    code_male = "M"
  )

  # Step 3: Add famID to match downstream expectations
  ped$famID <- 1

  # Step 4: Build connections as done in calculateConnections()
  connections <- ped[, c(
    "personID", "x_pos", "y_pos",
    "dadID", "momID", "spouseID", "famID"
  )]

  # Step 5: Run the function under test
  mom_coords <- getRelativeCoordinates(
    ped = ped,
    connections = connections,
    relativeIDvar = "momID",
    x_name = "x_mom",
    y_name = "y_mom"
  )

  # Step 6: Validate results
  # For people C and D (whose mom is A), we should get A's coordinates
  mom_row <- ped[ped$personID == "A", ]
  expected_x <- mom_row$x_pos
  expected_y <- mom_row$y_pos

  target <- mom_coords[mom_coords$personID %in% c("C", "D"), ]

  expect_equal(target$x_mom, rep(expected_x, 2))
  expect_equal(target$y_mom, rep(expected_y, 2))

  # Others (A and B, who have NA momID) should be excluded
  expect_false("A" %in% mom_coords$personID)
  expect_false("B" %in% mom_coords$personID)
})


test_that("calculateCoordinates fails on incorrect ped input", {
  expect_error(
    calculateCoordinates("not_a_df"),
    "ped should be a data.frame or inherit to a data.frame"
  )

  expect_error(
    calculateCoordinates(data.frame(ID = 1:3), personID = "ID"),
    "At least one of the required ID variables"
  )
})



test_that("calculateCoordinates uses default code_male = 1", {
  ped <- data.frame(
    ID = c("A", "B", "C", "D", "X"),
    momID = c(NA, "A", "A", "C", NA),
    dadID = c(NA, "X", "X", "B", NA),
    spouseID = c("X", "C", "B", NA, "A"),
    sex = c("F", "M", "F", "F", "M")
  )

  coords <- calculateCoordinates(ped, personID = "ID", config = list(debug = TRUE))
  expect_true(all(c("x_order", "y_order", "x_pos", "y_pos", "nid") %in% names(coords)))
  expect_true(all(coords$ID %in% ped$ID)) # ID retention
  expect_true(all(coords$momID %in% ped$momID)) # momID retention
  expect_true(all(coords$dadID %in% ped$dadID)) # dadID retention
  expect_true(all(coords$spouseID %in% ped$spouseID)) # spouseID retention
  expect_equal(nrow(coords), nrow(ped)) # no duplicates yet
  expect_equal(nrow(coords), 5)
  expect_true(all(!is.na(coords$x_order)))
})

test_that("calculateCoordinates returns extra rows when duplicated appearances", {
  ped <- data.frame(
    ID = c("P1", "P2", "P3"),
    momID = c(NA, NA, "P1"),
    dadID = c(NA, NA, "P2"),
    spouseID = c("P2", "P1", NA),
    sex = c("F", "M", "F")
  )

  coords <- calculateCoordinates(ped,
    code_male = "M", personID = "ID",
    spouseID = "spouseID"
  )

  # Manually simulate layout duplication
  expect_true("extra" %in% names(coords))
  expect_true(any(coords$extra == TRUE | coords$extra == FALSE))
})

test_that("calculateCoordinates handles missing spouseID column gracefully", {
  ped <- data.frame(
    ID = c("A", "B", "C", "D", "X"),
    momID = c(NA, "A", "A", "C", NA),
    dadID = c(NA, "X", "X", "B", NA),
    sex = c("F", "M", "F", "F", "M")
  )

  # No spouseID present, should still compute without error
  coords <- calculateCoordinates(ped, code_male = "M", personID = "ID")
  expect_true(all(c("x_order", "y_order", "x_pos", "y_pos", "nid") %in% names(coords)))
})

test_that("calculateCoordinates layout changes with ped_align and ped_packed", {
  ped <- data.frame(
    ID = c("A", "B", "C", "D", "X"),
    momID = c(NA, "A", "A", "C", NA),
    dadID = c(NA, "X", "X", "B", NA),
    spouseID = c("X", "C", "B", NA, "A"),
    sex = c("F", "M", "F", "F", "M")
  )

  coords_default <- calculateCoordinates(
    ped,
    personID = "ID",
    momID = "momID",
    dadID = "dadID",
    spouseID = "spouseID",
    sexVar = "sex",
    code_male = "M",
    config = list(ped_align = TRUE, ped_packed = TRUE)
  )

  coords_unaligned <- calculateCoordinates(
    ped,
    personID = "ID",
    momID = "momID",
    dadID = "dadID",
    spouseID = "spouseID",
    sexVar = "sex",
    code_male = "M",
    config = list(ped_align = FALSE, ped_packed = TRUE)
  )

  coords_unpacked <- calculateCoordinates(
    ped,
    personID = "ID",
    momID = "momID",
    dadID = "dadID",
    spouseID = "spouseID",
    sexVar = "sex",
    code_male = "M",
    config = list(ped_align = TRUE, ped_packed = FALSE)
  )

  # 1. Same IDs in all
  expect_setequal(coords_default$ID, coords_unaligned$ID)
  expect_setequal(coords_default$ID, coords_unpacked$ID)

  # 2. Actual layout changes
  layout_default <- coords_default[order(coords_default$ID), c("x_pos", "y_pos")]
  layout_unaligned <- coords_unaligned[order(coords_unaligned$ID), c("x_pos", "y_pos")]
  layout_unpacked <- coords_unpacked[order(coords_unpacked$ID), c("x_pos", "y_pos")]

  expect_false(identical(layout_default, layout_unaligned))
  expect_false(identical(layout_unaligned, layout_unpacked))
})