Wikitemplate parser

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: BGmisc
 Title: An R Package for Extended Behavior Genetics Analysis
-Version: 1.3.5.1
+Version: 1.3.6
 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,7 @@
 * revived checkParents function to check for handling phantom parents and missing parents
 * added tests for checkParents function
 * added GoT analysis
+* reduced complexity of com2links and summarizePedigree with the use of subfunctions
 
 # BGmisc 1.3.5.1
 * Setting the default for the `sparse` argument in `ped2com()` to TRUE

R/buildPedigree.R

@@ -1,6 +1,7 @@
 #' Segment Pedigree into Extended Families
 #'
-#' This function adds an extended family ID variable to a pedigree by segmenting that dataset into independent extended families
+#' This function adds an extended family ID variable to a pedigree by segmenting
+#' that dataset into independent extended families
 #' using the weakly connected components algorithm.
 #'
 #'
@@ -86,7 +87,8 @@
                       adjacent = c("parents", "mothers", "fathers"),
                       ...) {
   # Check ped/data.fram
-  if (!inherits(ped, "data.frame")) stop("ped should be a data.frame or inherit to a data.frame")
+  if (!inherits(ped, "data.frame")) {
+    stop("ped should be a data.frame or inherit to a data.frame")}
   # Handle adjacent argument
   adjacent <- match.arg(tolower(adjacent)[1],
     choices = c(
@@ -165,7 +167,7 @@
 
 #' Add a maternal line ID variable to a pedigree
 #' @inheritParams ped2fam
-#' @param matID Character.  Maternal line ID variable to be created and added to the pedigree
+#' @param matID Character. Maternal line ID variable to be created and added to the pedigree
 #' @details
 #' Under various scenarios it is useful to know which people in a pedigree
 #' belong to the same maternal lines.  This function first turns a pedigree
@@ -177,9 +179,11 @@
 #' @export
 #'
 ped2maternal <- function(ped, personID = "ID",
-                         momID = "momID", dadID = "dadID", matID = "matID", ...) {
+                         momID = "momID", dadID = "dadID",
+                         matID = "matID", ...) {
   # Call to wrapper function
-  .ped2id(ped = ped, personID = personID, momID = momID, dadID = dadID, famID = matID, type = "mothers")
+  .ped2id(ped = ped, personID = personID, momID = momID,
+          dadID = dadID, famID = matID, type = "mothers")
 }
 
 #' Add a paternal line ID variable to a pedigree
@@ -199,5 +203,6 @@
                          momID = "momID", dadID = "dadID",
                          patID = "patID", ...) {
   # Call to wrapper function
-  .ped2id(ped = ped, personID = personID, momID = momID, dadID = dadID, famID = patID, type = "fathers")
+  .ped2id(ped = ped, personID = personID, momID = momID,
+          dadID = dadID, famID = patID, type = "fathers")
 }

R/checkParents.R

@@ -23,8 +23,7 @@
 checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE,
                            repairsex = repair,
                            addphantoms = repair,
-                           parentswithoutrow = repair
-                           ) {
+                           parentswithoutrow = repair) {
   # Standardize column names in the input dataframe
   ped_og <- ped
   ped <- standardizeColnames(ped)
@@ -74,7 +73,7 @@
       cat("All parents are listed in the pedigree.\n")
     }
   }
-  validation_results$missing_parents <- validation_results$single_parents&length(rowless_parents) > 0
+  validation_results$missing_parents <- validation_results$single_parents & length(rowless_parents) > 0
 
   if (verbose) {
     cat("Step 2: Determining the if moms are the same sex and dads are same sex\n")
@@ -146,11 +145,13 @@
 
   # Are any parents in both momID and dadID?
   momdad <- intersect(ped$dadID, ped$momID)
-  if (!is.na(momdad)&&length(momdad) > 0) {
+  if (!is.na(momdad) && length(momdad) > 0) {
     validation_results$parents_in_both <- momdad
     if (verbose) {
-      cat(paste("Some individuals appear in both momID and dadID roles.\n",
-                "These individuals are:\n"))
+      cat(paste(
+        "Some individuals appear in both momID and dadID roles.\n",
+        "These individuals are:\n"
+      ))
       print(momdad)
     }
   }
@@ -162,12 +163,12 @@
       print(validation_results)
     }
     return(validation_results)
-  } else{
-  if (verbose) {
-    cat("Validation Results:\n")
-    print(validation_results)
-    cat("Step 3: Attempting to repair missing parents...\n")
-  }
+  } else {
+    if (verbose) {
+      cat("Validation Results:\n")
+      print(validation_results)
+      cat("Step 3: Attempting to repair missing parents...\n")
+    }
 
     cat("REPAIR IN EARLY ALPHA\n")
     # Initialize a list to track changes made during repair
@@ -177,32 +178,32 @@
       phantom_dads_added = c(),
       phantom_moms_added = c()
     )
-    if(repairsex){
-    # Fix sex of existing parents if wrong
-    mom_indices <- match(ped$momID, ped$ID)
-    dad_indices <- match(ped$dadID, ped$ID)
+    if (repairsex) {
+      # Fix sex of existing parents if wrong
+      mom_indices <- match(ped$momID, ped$ID)
+      dad_indices <- match(ped$dadID, ped$ID)
 
 
 
-    if (!is.na(validation_results$female_var)) {
-      corrected_moms <- ped$ID[mom_indices[!is.na(mom_indices)]]
-      ped$sex[mom_indices[!is.na(mom_indices)]] <- validation_results$female_var
-      changes$corrected_mom_sex <- corrected_moms
-      if (verbose && length(corrected_moms) > 0) {
-        cat("Corrected sex of moms for:", paste(corrected_moms, collapse = ", "), "\n")
+      if (!is.na(validation_results$female_var)) {
+        corrected_moms <- ped$ID[mom_indices[!is.na(mom_indices)]]
+        ped$sex[mom_indices[!is.na(mom_indices)]] <- validation_results$female_var
+        changes$corrected_mom_sex <- corrected_moms
+        if (verbose && length(corrected_moms) > 0) {
+          cat("Corrected sex of moms for:", paste(corrected_moms, collapse = ", "), "\n")
+        }
       }
-    }
-    if (!is.na(validation_results$male_var)) {
-      corrected_dads <- ped$ID[dad_indices[!is.na(dad_indices)]]
-      ped$sex[dad_indices[!is.na(dad_indices)]] <- validation_results$male_var
-      changes$corrected_dad_sex <- corrected_dads
-      if (verbose && length(corrected_dads) > 0) {
-        cat("Corrected sex of dads for:", paste(corrected_dads, collapse = ", "), "\n")
+      if (!is.na(validation_results$male_var)) {
+        corrected_dads <- ped$ID[dad_indices[!is.na(dad_indices)]]
+        ped$sex[dad_indices[!is.na(dad_indices)]] <- validation_results$male_var
+        changes$corrected_dad_sex <- corrected_dads
+        if (verbose && length(corrected_dads) > 0) {
+          cat("Corrected sex of dads for:", paste(corrected_dads, collapse = ", "), "\n")
+        }
       }
     }
-    }
-}
-if (addphantoms){
+  }
+  if (addphantoms) {
     # Generate new IDs
     newIDbase <- if (is.numeric(ped$ID)) max(ped$ID, na.rm = TRUE) + 1 else paste0("phantom-", seq_len(nrow(ped)))
     new_entries <- data.frame()
@@ -248,47 +249,47 @@
     if (verbose && length(changes$phantom_moms_added) > 0) {
       cat("Added phantom moms for:", paste(changes$phantom_moms_added, collapse = ", "), "\n")
     }
-}
+  }
   # add phantom parents
-  if(parentswithoutrow){
-  # Add parents who appear in momID or dadID but are missing from ID
-  listed_parents <- unique(c(ped$momID, ped$dadID))
-  listed_parents <- listed_parents[!is.na(listed_parents)]
-
-  existing_ids <- ped$ID
-  missing_parents <- setdiff(listed_parents, existing_ids)
-
-  if (length(missing_parents) > 0) {
-    if (verbose) {
-      cat("Adding parents who were listed in momID/dadID but missing from ID:\n")
-      print(missing_parents)
-    }
+  if (parentswithoutrow) {
+    # Add parents who appear in momID or dadID but are missing from ID
+    listed_parents <- unique(c(ped$momID, ped$dadID))
+    listed_parents <- listed_parents[!is.na(listed_parents)]
+
+    existing_ids <- ped$ID
+    missing_parents <- setdiff(listed_parents, existing_ids)
+
+    if (length(missing_parents) > 0) {
+      if (verbose) {
+        cat("Adding parents who were listed in momID/dadID but missing from ID:\n")
+        print(missing_parents)
+      }
 
-    for (pid in missing_parents) {
-      role <- unique(
-        c(
-          if (pid %in% ped$momID) "mom" else NULL,
-          if (pid %in% ped$dadID) "dad" else NULL
+      for (pid in missing_parents) {
+        role <- unique(
+          c(
+            if (pid %in% ped$momID) "mom" else NULL,
+            if (pid %in% ped$dadID) "dad" else NULL
+          )
         )
-      )
-      inferred_sex <- if ("mom" %in% role) validation_results$female_var else validation_results$male_var
-
-      new_row <- ped[1, ]
-      new_row$ID <- pid
-      new_row$dadID <- NA
-      new_row$momID <- NA
-      new_row$sex <- inferred_sex
-      new_entries <- rbind(new_entries, new_row)
+        inferred_sex <- if ("mom" %in% role) validation_results$female_var else validation_results$male_var
+
+        new_row <- ped[1, ]
+        new_row$ID <- pid
+        new_row$dadID <- NA
+        new_row$momID <- NA
+        new_row$sex <- inferred_sex
+        new_entries <- rbind(new_entries, new_row)
+      }
     }
-  }
-  ped <- merge(ped, new_entries, all = TRUE)
+    ped <- merge(ped, new_entries, all = TRUE)
   }
 
-    if (verbose) {
-      cat("Changes Made:\n")
-      print(changes)
-    }
-    return(ped)
+  if (verbose) {
+    cat("Changes Made:\n")
+    print(changes)
+  }
+  return(ped)
 }
 #' Repair Parent IDs
 #'

R/checkPedigree.R

@@ -13,8 +13,10 @@
 #' @return List containing detailed validation results.
 #' @examples
 #' \dontrun{
-#' results <- checkPedigreeNetwork(ped, personID = "ID",
-#' momID = "momID", dadID = "dadID", verbose = TRUE)
+#' results <- checkPedigreeNetwork(ped,
+#'   personID = "ID",
+#'   momID = "momID", dadID = "dadID", verbose = TRUE
+#' )
 #' }
 #' @export
 checkPedigreeNetwork <- function(ped, personID = "ID", momID = "momID", dadID = "dadID", verbose = FALSE) {

R/computeRelatedness.R

@@ -133,7 +133,6 @@ calculateH <- function(r1, r2, obsR1, obsR2) {
     message("Your scale might be reverse coded because you have negative correlations. Please check your data. ")
   }
 
-
   # Calculate heritability estimates (H^2) for all pairs
   heritability_estimates <- (obsR1 - obsR2) / (r1 - r2)
 
@@ -145,7 +144,5 @@ calculateH <- function(r1, r2, obsR1, obsR2) {
   if (any(heritability_estimates > 1)) {
     warning("Some calculated heritability values are greater than 1, which may suggest overestimation or errors in the observed correlations or relatedness coefficients.")
   }
-
-
   return(heritability_estimates)
 }

R/convertPedigree.R

@@ -95,7 +95,7 @@ ped2com <- function(ped, component,
 
   # standardize colnames
   if (standardize.colnames) {
-    ped <- standardizeColnames(ped)
+    ped <- standardizeColnames(ped, verbose = verbose)
   }
 
   # Load final result if computation was completed
@@ -212,7 +212,7 @@ ped2com <- function(ped, component,
   # isPar is the adjacency matrix.  'A' matrix from RAM
   if (component %in% c("common nuclear")) {
     Matrix::diag(isPar) <- 1
-    if (sparse==FALSE) {
+    if (sparse == FALSE) {
       isPar <- as.matrix(isPar)
     }
     return(isPar)
@@ -224,15 +224,8 @@ ped2com <- function(ped, component,
   } else {
     # isChild is the 'S' matrix from RAM
 
-    if (isChild_method == "partialparent") {
-      isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) {
-        .5 + .25 * sum(is.na(x)) # 2 parents -> .5, 1 parent -> .75, 0 parents -> 1
-      })
-    } else {
-      isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) {
-        2^(-!all(is.na(x)))
-      })
-    }
+    isChild <- isChild(isChild_method=isChild_method, ped=ped)
+
     if (saveable) {
       saveRDS(isChild, file = checkpoint_files$isChild)
     }
@@ -330,7 +323,7 @@ ped2com <- function(ped, component,
     # Assign 1 to all nonzero elements for mitochondrial component
   }
 
-  if (sparse==FALSE) {
+  if (sparse == FALSE) {
     r <- as.matrix(r)
   }
   if (flatten.diag) { # flattens diagonal if you don't want to deal with inbreeding
@@ -723,3 +716,22 @@ compute_parent_adjacency <- function(ped, component,
   }
   return(list_of_adjacency)
 }
+
+
+#' Determine isChild Status, isChild is the 'S' matrix from RAM
+#' @param isChild_method method to determine isChild status
+#' @param ped pedigree data frame
+#' @return isChild 'S' matrix
+#'
+
+isChild <- function(isChild_method, ped) {
+  if (isChild_method == "partialparent") {
+    isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) {
+      .5 + .25 * sum(is.na(x)) # 2 parents -> .5, 1 parent -> .75, 0 parents -> 1
+    })
+  } else {
+    isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) {
+      2^(-!all(is.na(x)))
+    })
+  }
+}