Add helper functions for pedigree checks and refactor

Introduces helper functions addIfAny and dropIdenticalDuplicateIDs to streamline pedigree validation and repair logic. Refactors checkIDs and checkParents to use these helpers, improving code clarity and modularity. Enhances restorePedColnames to be more robust and adds documentation for new helpers.

Author: smasongarrison

NAMESPACE

@@ -17,12 +17,10 @@ export(computeParentAdjacency)
 export(createGenDataFrame)
 export(determineSex)
 export(dropLink)
-export(evenInsert)
 export(fitComponentModel)
 export(getWikiTreeSummary)
 export(identifyComponentModel)
 export(inferRelatedness)
-export(insertEven)
 export(makeInbreeding)
 export(makeTwins)
 export(ped2add)

NEWS.md

@@ -1,4 +1,7 @@
 # BGmisc NEWS
+# Development version: 1.6.0.9000
+
+* Add helper functions for checkParents etc
 
 # BGmisc 1.6
 * Optimize  simulatePedigree and helpers for speed and memory usage

R/checkIDs.R

@@ -56,19 +56,12 @@ checkIDs <- function(ped, verbose = FALSE, repair = FALSE) {
     # if there are non-unique IDs
     if (length(validation_results$non_unique_ids) > 0) {
       # loop through each non-unique ID
-      for (id in validation_results$non_unique_ids) {
-        rows_with_id <- repaired_ped[repaired_ped$ID == id, ]
-        # If all rows with the same ID are truly identical, keep only the first occurrence
-        if (nrow(unique(rows_with_id)) == 1) {
-          # Mark as removed in the changes list
-          changes[[paste0("ID", id)]] <- "Removed duplicates"
-          # Keep only the first row, remove the rest
-          repaired_ped <- repaired_ped[-which(repaired_ped$ID == id)[-1], ] # Remove all but the first occurrence
-        } else {
-          # Mark as kept in the changes list
-          changes[[paste0("ID", id)]] <- "Kept duplicates"
-        }
-      }
+
+      processed <- dropIdenticalDuplicateIDs(ped = repaired_ped,
+        ids = validation_results$non_unique_ids,
+        changes = changes)
+      repaired_ped <- processed$ped
+      changes <- processed$changes
     }
     if (verbose == TRUE) {
       cat("Step 2: No repair for parents who are their children at this time\n")

R/checkParents.R

@@ -52,14 +52,14 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE,
   missing_mothers <- ped$ID[which(!is.na(ped$dadID) & is.na(ped$momID))]
 
   # Update the validation_results list
-  if (length(missing_fathers) > 0) {
-    validation_results$missing_fathers <- missing_fathers
-  }
-  if (length(missing_mothers) > 0) {
-    validation_results$missing_mothers <- missing_mothers
-  }
 
-  validation_results$single_parents <- length(validation_results) > 0
+  validation_results <- addIfAny(validation_results, "missing_fathers", missing_fathers)
+  validation_results <- addIfAny(validation_results, "missing_mothers", missing_mothers)
+
+  validation_results$single_parents <- (length(missing_fathers) + length(missing_mothers)) > 0
+
+
+
 
 
   if (verbose && validation_results$single_parents) cat("Missing single parents found.\n")
@@ -269,11 +269,12 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE,
   }
 
   # restore orginal names that the user orginally provided
-  names(ped)[names(ped) == "ID"] <- personID
-  names(ped)[names(ped) == "momID"] <- momID
-  names(ped)[names(ped) == "dadID"] <- dadID
-  names(ped)[names(ped) == "famID"] <- famID
-  return(ped)
+  ped <-  restorePedColnames(ped,
+    famID = famID,
+    personID = personID,
+    momID = momID,
+    dadID = dadID)
+
 }
 #' Repair Parent IDs
 #'

R/helpChecks.R

@@ -0,0 +1,47 @@
+#' Drop Identical Duplicate IDs from Pedigree Data Frame
+#'
+#' #' This function identifies and removes duplicate entries in a pedigree data frame
+#' based on a list of specified IDs. If multiple rows share the same ID and are
+#' identical, only one instance is retained. The function returns the modified pedigree
+#' data frame along with a log of changes made.
+#' @param ped A data frame representing the pedigree.
+#' @param ids A vector of IDs to check for duplicates in the pedigree.
+#' @param changes An optional list to log changes made during the process.
+dropIdenticalDuplicateIDs <- function(ped, ids, changes = NULL
+) {
+  if (!is.data.frame(ped)) {
+    stop("ped must be a data frame")
+  }
+  if (is.null(changes)) {
+    changes <- list()
+  } else if (!is.list(changes)) {
+    stop("changes must be a list or NULL")
+  }
+
+  out <- ped
+
+  if (!is.null(ids) && length(ids) > 0) {
+    for (id in ids) {
+      rows_with_id <- out[out$ID == id, , drop = FALSE]
+      if (nrow(unique(rows_with_id)) == 1) {
+        changes[[paste0("ID", id)]] <- "Removed duplicates"
+        out <- out[-which(out$ID == id)[-1], , drop = FALSE]
+      } else {
+        changes[[paste0("ID", id)]] <- "Kept duplicates"
+      }
+    }
+  }
+
+  list(ped = out, changes = changes)
+}
+
+#' Helper function to conditionally add elements to a list
+#' @param validation A list to which elements may be added.
+#' @param name A character string representing the name of the element to add.
+#' @param value The value to add to the list if it is not NULL or empty
+#' @return The updated list with the new element added if applicable.
+#' @keywords internal
+addIfAny <- function(validation, name, value) {
+  if (!is.null(value) && length(value) > 0) validation[[name]] <- value
+  validation
+}

R/helpNames.R

@@ -71,20 +71,49 @@ restorePedColnames <- function(ped,
                                spID = "spID",
                                twinID = "twinID",
                                zygosity = "zygosity",
-                               sex = "sex"
+                               sex = "sex",
+                               verbose = FALSE
 ) {
+  if (verbose == TRUE) {
+    message("Restoring original column names...")
+  }
+  if (!inherits(ped, "data.frame")) {
+    stop("ped should be a data.frame or inherit to a data.frame")
+  }
+  if (!is.null(personID) && !is.null(ped$ID)) {
+    names(ped)[names(ped) == "ID"] <- personID
+  }
+  if (!is.null(momID) && !is.null(ped$momID)) {
+    names(ped)[names(ped) == "momID"] <- momID
+  }
+  if (!is.null(dadID) && !is.null(ped$dadID)) {
+    names(ped)[names(ped) == "dadID"] <- dadID
+  }
 
-  names(ped)[names(ped) == "ID"] <- personID
-  names(ped)[names(ped) == "momID"] <- momID
-  names(ped)[names(ped) == "dadID"] <- dadID
-  names(ped)[names(ped) == "famID"] <- famID
-  names(ped)[names(ped) == "gen"] <- gen
-  names(ped)[names(ped) == "patID"] <- patID
-  names(ped)[names(ped) == "matID"] <- matID
-  names(ped)[names(ped) == "spID"] <- spID
-  names(ped)[names(ped) == "twinID"] <- twinID
-  names(ped)[names(ped) == "zygosity"] <- zygosity
-  names(ped)[names(ped) == "sex"] <- sex
+  if (!is.null(famID) && !is.null(ped$famID)) {
+    names(ped)[names(ped) == "famID"] <- famID
+  }
+  if (!is.null(gen) && !is.null(ped$gen)) {
+    names(ped)[names(ped) == "gen"] <- gen
+  }
+  if (!is.null(patID) && !is.null(ped$patID)) {
+    names(ped)[names(ped) == "patID"] <- patID
+  }
+  if (!is.null(matID) && !is.null(ped$matID)) {
+    names(ped)[names(ped) == "matID"] <- matID
+  }
+  if (!is.null(spID) && !is.null(ped$spID)) {
+    names(ped)[names(ped) == "spID"] <- spID
+  }
+  if (!is.null(twinID) && !is.null(ped$twinID)) {
+    names(ped)[names(ped) == "twinID"] <- twinID
+  }
+  if (!is.null(zygosity) && !is.null(ped$zygosity)) {
+    names(ped)[names(ped) == "zygosity"] <- zygosity
+  }
+  if (!is.null(sex) && !is.null(ped$sex)) {
+    names(ped)[names(ped) == "sex"] <- sex
+  }
   ped
 }