Merge pull request #105 from R-Computing-Lab/dev_main

character or factor ID variables fix

Author: smasongarrison

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: BGmisc
 Title: An R Package for Extended Behavior Genetics Analysis
-Version: 1.5.1.009
+Version: 1.5.2
 Authors@R: c(
     person("S. Mason", "Garrison", , "garrissm@wfu.edu", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0002-4804-6003")),

NEWS.md

@@ -2,6 +2,8 @@
 * More flexible ID generation for simulatePedigree
 * Created ped2gen function to extract generation information from pedigree data.frames
 * Added tests for ped2gen
+* Fixed handling of character ID variables leading to a warning in ped2fam
+* Added famIDs to phantom parents
 
 # BGmisc 1.5.1
 ## CRAN submission

R/checkParents.R

@@ -173,7 +173,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE,
       }
     }
   }
-  if (addphantoms) {
+  if (addphantoms==TRUE) {
     # Generate new IDs
     newIDbase <- if (is.numeric(ped$ID)) max(ped$ID, na.rm = TRUE) + 1 else paste0("phantom-", seq_len(nrow(ped)))
     # Initialize a dataframe to store new entries
@@ -196,19 +196,38 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE,
       newID <- if (is.numeric(ped$ID)) newIDbase + added_counter else paste0("phantom-dad-", ped$ID[idx])
       added_counter <- added_counter + 1
       ped$dadID[idx] <- newID
+      if ("famID" %in% names(ped)){
+        newFAMID  <-  unique(ped$famID[idx])
+        newFAMID <- newFAMID[!is.na(newFAMID)]
 
-
+      new_entry <- addParentRow(new_entry_base, newID = newID, dadID = NA, momID = NA, sex = inferred_sex, famID = newFAMID)
+      } else {
       new_entry <- addParentRow(new_entry_base, newID = newID, dadID = NA, momID = NA, sex = inferred_sex)
+      }
       new_entries <- rbind(new_entries, new_entry)
     }
 
     # Add moms when missing
-    inferred_sex <- if (length(validation_results$female_var) > 0 && !is.na(validation_results$female_var)) validation_results$female_var else 0
+    inferred_sex <- if (length(validation_results$female_var) > 0 && !is.na(validation_results$female_var)){
+      validation_results$female_var
+    } else {
+        0
+      }
+
     for (idx in which(!is.na(ped$dadID) & is.na(ped$momID))) {
       newID <- if (is.numeric(ped$ID)) newIDbase + added_counter else paste0("phantom-mom-", ped$ID[idx])
       added_counter <- added_counter + 1
       ped$momID[idx] <- newID
+
+      if ("famID" %in% names(ped)){
+        newFAMID  <-  unique(ped$famID[idx])
+        newFAMID <- newFAMID[!is.na(newFAMID)]
+
+        new_entry <- addParentRow(new_entry_base, newID = newID, dadID = NA, momID = NA, sex = inferred_sex, famID = newFAMID)
+      } else {
+
       new_entry <- addParentRow(new_entry_base, newID = newID, dadID = NA, momID = NA, sex = inferred_sex)
+      }
       new_entries <- rbind(new_entries, new_entry)
     }
 
@@ -300,7 +319,19 @@ addRowlessParents <- function(ped, verbose, validation_results) {
       )
       inferred_sex <- if ("mom" %in% role) validation_results$female_var else validation_results$male_var
 
-      new_entry <- addParentRow(new_entry_base, newID = pid, dadID = NA, momID = NA, sex = inferred_sex)
+      if("famID" %in% names(ped)){
+      newFAMID  <-  unique(ped$famID[which(ped$momID == pid | ped$dadID == pid)])
+      newFAMID <- newFAMID[!is.na(newFAMID)]
+
+
+      if(length(newFAMID) >1){
+        newFAMID <- NA
+      }
+
+      new_entry <- addParentRow(new_entry_base, newID = pid, dadID = NA, momID = NA, sex = inferred_sex, famID = newFAMID)
+      } else {
+        new_entry <- addParentRow(new_entry_base, newID = pid, dadID = NA, momID = NA, sex = inferred_sex)
+      }
 
       new_entries <- rbind(new_entries, new_entry)
     }
@@ -324,16 +355,24 @@ addRowlessParents <- function(ped, verbose, validation_results) {
 #' @param sex The new parent's sex value (e.g., 0 for female, 1 for male, or "F"/"M")
 #' @param momID The new parent's mother ID (default is NA)
 #' @param dadID The new parent's father ID (default is NA)
+#' @param famID The new parent's family ID (default is NA)
 #' @return A single-row dataframe for the new parent
 addParentRow <- function(template_row, newID, sex,
                          momID = NA,
-                         dadID = NA) {
+                         dadID = NA,
+                         famID = NA
+                         ) {
   new_row <- template_row
   new_row[] <- NA # set all columns to NA
   new_row$ID <- newID
-  new_row$momID <- NA
-  new_row$dadID <- NA
+  new_row$momID <- momID
+  new_row$dadID <- dadID
   new_row$sex <- sex
+
+  if ("famID" %in% names(template_row)) {
+    new_row$famID <- famID
+  }
   # You can add more column initializations here if needed
+
   return(new_row)
 }

R/segmentPedigree.R

@@ -44,10 +44,24 @@ ped2fam <- function(ped, personID = "ID",
   # Find weakly connected components of graph
   wcc <- igraph::components(pg)
 
-  fam <- data.frame(
-    V1 = as.numeric(names(wcc$membership)),
-    V2 = wcc$membership
-  )
+  # Create famID data.frame
+  # Convert IDs to numeric, with warning if coercion collapses IDs
+  uniques <- suppressWarnings(unique(as.numeric(names(wcc$membership))))
+
+  if (length(uniques) == 1L && is.na(uniques)) {
+    warning("After converting IDs to numeric, all IDs became NA. This indicates ID coercion collapsed IDs. Please ensure IDs aren't character or factor variables.")
+
+    fam <- data.frame(
+      V1 = names(wcc$membership),
+      V2 = wcc$membership
+    )
+  } else {
+    fam <- data.frame(
+      V1 = as.numeric(names(wcc$membership)),
+      V2 = wcc$membership
+    )
+  }
+
   names(fam) <- c(personID, famID)
   ped2 <- merge(fam, ped,
     by = personID, all.x = FALSE, all.y = TRUE

man/addParentRow.Rd

@@ -24,6 +24,15 @@ test_that("checksif single parents found correctly in ASOIAF dataset", {
   expect_equal(single_dads, length(results$missing_mothers))
   repaired_df <- checkParentIDs(df_asoiaf, verbose = FALSE, repair = TRUE, parentswithoutrow = TRUE)
   expect_equal(nrow(repaired_df), nrow(df_asoiaf) + single_moms + single_dads)
+
+
+  repaired_phantoms <- checkParentIDs(df_asoiaf, verbose = FALSE, repair = TRUE, addphantoms =  TRUE)
+  expect_equal(nrow(repaired_phantoms), nrow(df_asoiaf) + single_moms + single_dads)
+  # did it add more famIDs?
+  expect_true(length(repaired_phantoms$famID[!is.na(repaired_phantoms$famID)]) > length(df_asoiaf$famID[!is.na(df_asoiaf$famID)]))
+  # do the original famIDs remain unique?
+  expect_true(length(unique(repaired_phantoms$famID[!is.na(repaired_phantoms$famID)])) == length(unique(df_asoiaf$famID[!is.na(df_asoiaf$famID)])))
+
 })
 
 test_that("verbose checks", {

tests/testthat/test-checkParents.R

@@ -1,10 +1,38 @@
+test_that("ped2fam is smart about string ids", {
+  data(hazard)
+  ds_num <- ped2fam(hazard, famID = "newFamID")
+  expect_true(is.numeric(ds_num$ID))
+  expect_true(is.numeric(ds_num$newFamID))
+  hazard$ID_og <- hazard$ID
+  hazard$ID <- paste0("ID", hazard$ID)
+  hazard$dadID <- paste0("ID", hazard$dadID)
+  hazard$dadID[hazard$dadID == "IDNA"] <- NA
+  hazard$momID <- paste0("ID", hazard$momID)
+  hazard$momID[hazard$momID == "IDNA"] <- NA
+  expect_warning(ped2fam(hazard, famID = "newFamID"))
+  ds <- suppressWarnings(ped2fam(hazard, famID = "newFamID"))
+  tab <- table(ds$famID, ds$newFamID)
+  expect_true(all(grepl("^ID", ds$ID)))
+  ds_num_s <- ds_num[order(ds_num$ID), ]
+  hazard_s <- hazard[order(hazard$ID_og), ]
+  ds_s <- ds[order(ds$ID_og), ]
+  expect_equal(ds_num_s$ID, hazard_s$ID_og)
+  expect_equal(ds_num_s$newFamID, hazard_s$famID)
+  expect_equal(ds_s$ID, hazard_s$ID)
+  expect_equal(ds_num_s$newFamID, hazard_s$famID)
+  expect_equal(ds_num_s$newFamID, ds_s$newFamID)
+  expect_equal(ds_s$famID, ds_s$newFamID)
+})
+
+
 test_that("ped2fam gets the right families for hazard data", {
   data(hazard)
   ds <- ped2fam(hazard, famID = "newFamID")
   tab <- table(ds$famID, ds$newFamID)
   expect_equal(ds$famID, ds$newFamID)
 })
 
+
 test_that("ped2fam gets the right families for inbreeding data", {
   data(inbreeding)
   ds <- ped2fam(inbreeding, famID = "newFamID")