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

1.3.5 update

Author: smasongarrison

.Rbuildignore

@@ -21,3 +21,4 @@ CITATION.cff$
 ^_pkgdown\.yml$
 ^docs$
 ^pkgdown$
+^\.vscode$

.gitignore

@@ -13,3 +13,5 @@ tests/testthat/Rplots.pdf
 ASOIAF.ged
 *.Rproj
 
+.vscode/launch.json
+dataRelatedPairs_new2.csv

.lintr

@@ -1,2 +1,5 @@
-linters: linters_with_defaults(line_length_linter(120),commented_code_linter = NULL,object_name_linter = object_name_linter(styles = c("snake_case", "symbols"))) # see vignette("lintr")
+linters: linters_with_defaults(
+  line_length_linter = NULL,
+  commented_code_linter = NULL, 
+  object_name_linter=NULL) # see vignette("lintr")
 encoding: "UTF-8"

BGmisc.Rproj

@@ -1,4 +1,5 @@
 Version: 1.0
+ProjectId: 660dde05-601d-4692-8962-9a2223744832
 
 RestoreWorkspace: No
 SaveWorkspace: No

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: BGmisc
 Title: An R Package for Extended Behavior Genetics Analysis
-Version: 1.3.3
+Version: 1.3.5
 Authors@R: c(
     person("S. Mason", "Garrison", , "garrissm@wfu.edu", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0002-4804-6003")),
@@ -33,8 +33,10 @@ Imports:
     kinship2,
     Matrix,
     stats,
-    stringr
+    stringr,
+    methods
 Suggests: 
+    corrplot,
     dplyr,
     EasyMx,
     knitr,

NAMESPACE

@@ -4,17 +4,21 @@ export(SimPed)
 export(allGens)
 export(calculateRelatedness)
 export(checkIDs)
+export(checkPedigreeNetwork)
 export(checkSex)
+export(com2links)
 export(comp2vech)
 export(createGenDataFrame)
 export(dropLink)
 export(evenInsert)
+export(extractSummaryText)
 export(famSizeCal)
 export(fitComponentModel)
 export(identifyComponentModel)
 export(inferRelatedness)
 export(makeInbreeding)
 export(makeTwins)
+export(parseTree)
 export(ped2add)
 export(ped2ce)
 export(ped2cn)
@@ -26,6 +30,7 @@ export(ped2mit)
 export(ped2paternal)
 export(plotPedigree)
 export(readGedcom)
+export(readWikifamilytree)
 export(recodeSex)
 export(related_coef)
 export(relatedness)

NEWS.md

@@ -1,3 +1,20 @@
+# BGmisc 1.3.5
+* Added ASOIAF pedigree
+* Added com2links() function to convert components to kinship links, with accompanying tests
+* Added extractWikiFamilyTree() function to parse family trees from wiki templates, with accompanying tests
+* Created vignette demonstrating adjacency matrix methods and applications
+* Improved plotPedigree() function by silencing unnecessary invisible list outputs
+* Added checkPedigreeNetwork() function for validating pedigree network structure, with accompanying tests
+
+# BGmisc 1.3.4.1
+* Hot fix to resolve issue with list of adjacency matrix not loading saved version
+* Reoptimized generation calculation
+
+# BGmisc 1.3.4
+* Added alternative (and faster) methods to create the adjacency matrix
+* Add tests for comparison of adjacency matrix build methods
+* Added Royal Family pedigree
+
 # BGmisc 1.3.3
 * Added ability to save and reload pedigree objects that are used by ped2Com
 * Optimized generation calculation

R/buildPedigree.R

@@ -51,7 +51,6 @@ ped2fam <- function(ped, personID = "ID",
   ped2 <- merge(fam, ped,
     by = personID, all.x = FALSE, all.y = TRUE
   )
-
   return(ped2)
 }
 

R/checkPedigree.R

@@ -0,0 +1,79 @@
+#' Validate Pedigree Network Structure
+#'
+#' Checks for structural issues in pedigree networks, including:
+#' - Individuals with more than two parents.
+#' - Presence of cyclic parent-child relationships.
+#'
+#' @param ped Dataframe representing the pedigree.
+#' @param personID Character. Column name for individual IDs.
+#' @param momID Character. Column name for maternal IDs.
+#' @param dadID Character. Column name for paternal IDs.
+#' @param verbose Logical. If TRUE, print informative messages.
+#'
+#' @return List containing detailed validation results.
+#' @examples
+#' \dontrun{
+#' results <- checkPedigreeNetwork(ped, personID = "ID",
+#' momID = "momID", dadID = "dadID", verbose = TRUE)
+#' }
+#' @export
+checkPedigreeNetwork <- function(ped, personID = "ID", momID = "momID", dadID = "dadID", verbose = FALSE) {
+  # Create directed edges from parent to child relationships
+  ped_edges <- rbind(
+    data.frame(from = ped[[momID]], to = ped[[personID]]),
+    data.frame(from = ped[[dadID]], to = ped[[personID]])
+  )
+  ped_edges <- ped_edges[!is.na(ped_edges$from) & !is.na(ped_edges$to), ]
+
+  ped_graph <- igraph::graph_from_data_frame(ped_edges, directed = TRUE)
+
+  results <- list()
+
+  ## Check for individuals with more than two parents
+  indegrees <- igraph::degree(ped_graph, mode = "in")
+  ids_excess_parents <- names(indegrees[indegrees > 2])
+
+  results$individuals_with_excess_parents <- ids_excess_parents
+
+  if (verbose) {
+    if (length(ids_excess_parents) > 0) {
+      message("Individuals with more than two parents detected: ", paste(ids_excess_parents, collapse = ", "))
+    } else {
+      message("No individuals with more than two parents detected.")
+    }
+  }
+
+  ## Check for duplicate edges
+
+  duplicate_edges_idx <- igraph::which_multiple(ped_graph)
+  duplicate_edges <- igraph::as_edgelist(ped_graph)[duplicate_edges_idx, , drop = FALSE]
+
+  results$duplicate_edges <- duplicate_edges
+
+  if (verbose) {
+    if (nrow(duplicate_edges) > 0) {
+      message("Duplicate edges detected:")
+      print(duplicate_edges)
+    } else {
+      message("No duplicate edges detected.")
+    }
+  }
+  ## Check for cyclic relationships
+  is_acyclic <- igraph::is_dag(ped_graph)
+  results$is_acyclic <- is_acyclic
+
+  if (!is_acyclic) {
+    cyclic_edges <- igraph::feedback_arc_set(ped_graph)
+    cyclic_relationships <- igraph::as_edgelist(ped_graph)[cyclic_edges, ]
+    results$cyclic_relationships <- cyclic_relationships
+    if (verbose) {
+      message("Cyclic relationships detected:")
+      print(cyclic_relationships)
+    }
+  } else {
+    results$cyclic_relationships <- NULL
+    if (verbose) message("No cyclic relationships detected.")
+  }
+
+  return(results)
+}

R/checkSex.R

@@ -53,10 +53,8 @@ checkSex <- function(ped, code_male = NULL, code_female = NULL, verbose = FALSE,
   validation_results$sex_unique <- unique(ped$sex)
   validation_results$sex_length <- length(unique(ped$sex))
   if (verbose) {
-    cat(paste0(
-      validation_results$sex_length, " unique values found.\n ",
-      paste0(validation_results$sex_unique)
-    ))
+    cat(paste0(validation_results$sex_length, " unique values found.\n"))
+    cat(paste0("Unique values: ", paste0(validation_results$sex_unique, collapse = ", "), "\n"))
   }
   # Are there multiple sexes/genders in the list of dads and moms?
 
@@ -83,7 +81,6 @@ checkSex <- function(ped, code_male = NULL, code_female = NULL, verbose = FALSE,
     remove(df_moms)
   }
 
-
   if (repair) {
     if (verbose) {
       cat("Step 2: Attempting to repair sex coding...\n")
@@ -99,7 +96,7 @@ checkSex <- function(ped, code_male = NULL, code_female = NULL, verbose = FALSE,
       num_changes <- sum(original_ped$sex != ped$sex)
       # Record the change and the count
       changes[[length(changes) + 1]] <- sprintf(
-        "Recode sex based on most frequent sex in dads: %s. Total gender changes made: %d",
+        "Recode sex based on most frequent sex in dads: %s. Total sex changes made:  %d",
         validation_results$most_frequent_sex_dad, num_changes
       )
     }
@@ -138,8 +135,8 @@ checkSex <- function(ped, code_male = NULL, code_female = NULL, verbose = FALSE,
 #' @export
 #'
 #' @seealso \code{\link{checkSex}}
-repairSex <- function(ped, verbose = FALSE, code_male = NULL) {
-  checkSex(ped = ped, verbose = verbose, repair = TRUE, code_male = code_male)
+repairSex <- function(ped, verbose = FALSE, code_male = NULL, code_female = NULL) {
+  checkSex(ped = ped, verbose = verbose, repair = TRUE, code_male = code_male, code_female = code_female)
 }
 
 #' Recodes Sex Variable in a Pedigree Dataframe
@@ -164,25 +161,24 @@ recodeSex <- function(
   if (!is.null(code_na)) {
     ped$sex[ped$sex == code_na] <- NA
   }
-
   # Recode as "F" or "M" based on code_male, preserving NAs
-  if (!is.null(code_male) & !is.null(code_female)) {
+  if (!is.null(code_male) && !is.null(code_female)) {
     # Initialize sex_recode as NA, preserving the length of the 'sex' column
     ped$sex_recode <- recode_na
     ped$sex_recode[ped$sex == code_female] <- recode_female
     ped$sex_recode[ped$sex == code_male] <- recode_male
     # Overwriting temp recode variable
     ped$sex <- ped$sex_recode
     ped$sex_recode <- NULL
-  } else if (!is.null(code_male) & is.null(code_female)) {
+  } else if (!is.null(code_male) && is.null(code_female)) {
     # Initialize sex_recode as NA, preserving the length of the 'sex' column
     ped$sex_recode <- recode_na
     ped$sex_recode[ped$sex != code_male & !is.na(ped$sex)] <- recode_female
     ped$sex_recode[ped$sex == code_male] <- recode_male
     # Overwriting temp recode variable
     ped$sex <- ped$sex_recode
     ped$sex_recode <- NULL
-  } else if (is.null(code_male) & !is.null(code_female)) {
+  } else if (is.null(code_male) && !is.null(code_female)) {
     # Initialize sex_recode as NA, preserving the length of the 'sex' column
     ped$sex_recode <- recode_na
     ped$sex_recode[ped$sex != code_female & !is.na(ped$sex)] <- recode_male