Wikitemplate parser

.gitignore

@@ -12,7 +12,8 @@ tests/testthat/Rplots.pdf
 *.ASOIAF.ged
 ASOIAF.ged
 *.Rproj
-
+benchmark_results.csv
 .vscode/launch.json
 dataRelatedPairs_new2.csv
 data-raw/ASOIAF_040725.ged
+dataRelatedPairs.csv

NAMESPACE

@@ -2,6 +2,9 @@
 
 export(SimPed)
 export(allGens)
+export(assignCoupleIDs)
+export(calcAllGens)
+export(calcFamilySize)
 export(calculateRelatedness)
 export(checkIDs)
 export(checkParentIDs)
@@ -17,6 +20,7 @@ export(famSizeCal)
 export(fitComponentModel)
 export(identifyComponentModel)
 export(inferRelatedness)
+export(insertEven)
 export(makeInbreeding)
 export(makeTwins)
 export(parseTree)
@@ -30,14 +34,21 @@ export(ped2maternal)
 export(ped2mit)
 export(ped2paternal)
 export(plotPedigree)
+export(readGed)
 export(readGedcom)
 export(readWikifamilytree)
+export(readgedcom)
 export(recodeSex)
 export(related_coef)
 export(relatedness)
 export(repairSex)
 export(resample)
 export(simulatePedigree)
+export(sizeAllGens)
+export(summariseFamilies)
+export(summariseMatrilines)
+export(summarisePatrilines)
+export(summarisePedigrees)
 export(summarizeFamilies)
 export(summarizeMatrilines)
 export(summarizePatrilines)

NEWS.md

@@ -2,7 +2,11 @@
 * 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
+* reduced complexity of com2links, summarizePedigree, and checkIDs with the use of subfunctions
+* allow verbose argument to be passed to standardizeColnames
+* list SimPed and related_coef as aliases for functions
+* harmonizing function names like calcFamilySize from famSizeCal
+* implemented adjBeta function to evaluation alternative build method
 
 # BGmisc 1.3.5.1
 * Setting the default for the `sparse` argument in `ped2com()` to TRUE

R/buildPedigree.R

@@ -88,7 +88,8 @@
                       ...) {
   # Check ped/data.fram
   if (!inherits(ped, "data.frame")) {
-    stop("ped should be a data.frame or inherit to a 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(
@@ -182,8 +183,10 @@
                          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
@@ -203,6 +206,8 @@
                          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/calculateFamilySize.R

@@ -5,7 +5,7 @@
 #' @param marR Mating rate (numeric value ranging from 0 to 1).
 #' @return Returns a vector containing the number of individuals in every generation.
 #' @export
-allGens <- function(kpc, Ngen, marR) {
+calcAllGens <- function(kpc, Ngen, marR) {
   # Check if the number of generations is valid
   if (Ngen < 1) {
     stop("The number of generations should be an integer greater or equal than 1")
@@ -23,14 +23,16 @@ allGens <- function(kpc, Ngen, marR) {
   }
   return(allGens)
 }
-
+#' @rdname calcAllGens
+#' @export
+allGens <- calcAllGens
 
 #' sizeAllGens
 #' An internal supporting function for \code{simulatePedigree}.
-#' @inheritParams allGens
+#' @inheritParams calcAllGens
 #' @return Returns a vector including the number of individuals in every generation.
 
-sizeAllGens <- function(kpc, Ngen, marR) {
+calcFamilySizeByGen <- function(kpc, Ngen, marR) {
   Nmid <- Ngen - 2
   midGens <- numeric(length = Nmid)
 
@@ -46,14 +48,16 @@ sizeAllGens <- function(kpc, Ngen, marR) {
   # print(allGens)
   return(allGens)
 }
-
+#' @rdname calcFamilySizeByGen
+#' @export
+sizeAllGens <- calcFamilySizeByGen
 
 #' famSizeCal
 #' A function to calculate the total number of individuals in a pedigree given parameters. This is a supporting function for function \code{simulatePedigree}
-#' @inheritParams allGens
+#' @inheritParams calcAllGens
 #' @return Returns a numeric value indicating the total pedigree size.
 #' @export
-famSizeCal <- function(kpc, Ngen, marR) {
+calcFamilySize <- function(kpc, Ngen, marR) {
   if (Ngen < 1) {
     stop("The number of generations should be an integer greater than or equal to 1")
   } else if (Ngen == 1) {
@@ -71,3 +75,8 @@ famSizeCal <- function(kpc, Ngen, marR) {
   }
   return(size)
 }
+
+#' @rdname calcFamilySize
+#' @export
+#'
+famSizeCal <- calcFamilySize

R/checkIDs.R

@@ -17,7 +17,7 @@
 #' @export
 checkIDs <- function(ped, verbose = FALSE, repair = FALSE) {
   # Standardize column names in the input dataframe
-  ped <- standardizeColnames(ped)
+  ped <- standardizeColnames(ped, verbose = verbose)
 
   # Initialize a list to store validation results
   validation_results <- list()
@@ -28,91 +28,15 @@
   }
 
   # Identify non-unique IDs
-  duplicated_ids <- ped$ID[duplicated(ped$ID) | duplicated(ped$ID, fromLast = TRUE)]
-
+  id_check <- checkIDuniqueness(ped = ped, verbose = verbose)
 
-  # Update the validation_results list
-  if (length(duplicated_ids) > 0) {
-    if (verbose) {
-      cat(paste0(length(duplicated_ids), " non-unique IDs found.\n"))
-    }
-    validation_results$all_unique_ids <- FALSE
-    validation_results$total_non_unique_ids <- length(duplicated_ids)
-    validation_results$non_unique_ids <- unique(duplicated_ids)
-  } else {
-    if (verbose) {
-      cat("All IDs are unique.\n")
-    }
-    validation_results$all_unique_ids <- TRUE
-    validation_results$total_non_unique_ids <- 0
-    validation_results$non_unique_ids <- NULL
-  }
   if (verbose) {
     cat("Step 2: Checking for within row duplicats...\n")
-    cat("Is own father?\n")
-  }
-  is_own_father <- ped$ID[ped$ID == ped$dadID & !is.na(ped$dadID)]
-  if (verbose) {
-    cat("Is own mother?\n")
-  }
-  is_own_mother <- ped$ID[ped$ID == ped$momID & !is.na(ped$momID)]
-  if (verbose) {
-    cat("Is mother father?\n")
   }
-  duplicated_parents <- ped$ID[ped$dadID == ped$momID & !is.na(ped$dadID) & !is.na(ped$momID)]
+  row_check <- checkWithinRowDuplicates(ped = ped, verbose = verbose)
 
-  # get the total number of within row duplicates
-  validation_results$total_own_father <- length(is_own_father)
-  validation_results$total_own_mother <- length(is_own_mother)
-  validation_results$total_duplicated_parents <- length(duplicated_parents)
-  validation_results$total_within_row_duplicates <- sum(length(is_own_father), length(is_own_mother), length(duplicated_parents))
-  # Update the validation_results list
+  validation_results <- c(id_check, row_check)
 
-  if (validation_results$total_within_row_duplicates > 0) {
-    if (verbose) {
-      cat(paste0(
-        validation_results$total_within_row_duplicates,
-        " within row duplicates found.\n"
-      ))
-    }
-    validation_results$within_row_duplicates <- TRUE
-    if (validation_results$total_own_father > 0) {
-      validation_results$is_own_father_ids <- unique(is_own_father)
-      if (verbose) {
-        cat(paste0(
-          validation_results$total_own_father,
-          " individuals are their own fathers.\n"
-        ))
-      }
-    }
-    if (validation_results$total_own_mother > 0) {
-      validation_results$is_own_mother_ids <- unique(is_own_mother)
-      if (verbose) {
-        cat(paste0(
-          validation_results$total_own_mother,
-          " individuals are their own mothers.\n"
-        ))
-      }
-    }
-    if (validation_results$total_duplicated_parents > 0) {
-      validation_results$duplicated_parents_ids <- unique(duplicated_parents)
-      if (verbose) {
-        cat(paste0(
-          validation_results$total_duplicated_parents,
-          " individuals have the same mother and father.\n"
-        ))
-      }
-    }
-  } else {
-    if (verbose) {
-      cat("No within row duplicates found.\n")
-    }
-    validation_results$within_row_duplicates <- FALSE
-    validation_results$total_within_row_duplicates <- 0
-    validation_results$is_own_father_ids <- NULL
-    validation_results$is_own_mother_ids <- NULL
-    validation_results$duplicated_parents_ids <- NULL
-  }
   if (verbose) {
     cat("Validation Results:\n")
     print(validation_results)
@@ -163,9 +87,82 @@
 #' Repair Missing IDs
 #'
 #' This function repairs missing IDs in a pedigree.
-#' @param ped A pedigree object
-#' @param verbose A logical indicating whether to print progress messages
+#' @inheritParams checkIDs
 #' @return A corrected pedigree
 repairIDs <- function(ped, verbose = FALSE) {
   checkIDs(ped = ped, verbose = verbose, repair = TRUE)
 }
+
+#' Check for duplicated individual IDs
+#'
+#' This function checks for duplicated individual IDs in a pedigree.
+#'
+#' @inheritParams checkIDs
+#' @return A list containing the results of the check
+#'
+checkIDuniqueness <- function(ped, verbose = FALSE) {
+  # Identify non-unique IDs
+
+  duplicated_ids <- ped$ID[duplicated(ped$ID) | duplicated(ped$ID, fromLast = TRUE)]
+
+  if (verbose) {
+    if (length(duplicated_ids) > 0) {
+      cat(length(duplicated_ids), " non-unique IDs found.\n")
+    } else {
+      cat("All IDs are unique.\n")
+    }
+  }
+
+  # Update the validation_results list
+  list(
+    all_unique_ids = length(duplicated_ids) == 0,
+    total_non_unique_ids = length(duplicated_ids),
+    non_unique_ids = if (length(duplicated_ids) > 0) unique(duplicated_ids) else NULL
+  )
+}
+
+
+
+#' Check for within-row duplicates (self-parents, same mom/dad)
+#'
+#' This function checks for within-row duplicates in a pedigree.
+#'
+#' @inheritParams checkIDs
+#' @return A list containing the results of the check
+#'
+checkWithinRowDuplicates <- function(ped, verbose = FALSE) {
+  # is the individual their own father or mother?
+  is_own_father <- ped$ID[ped$ID == ped$dadID & !is.na(ped$dadID)]
+  is_own_mother <- ped$ID[ped$ID == ped$momID & !is.na(ped$momID)]
+
+  # is mother and father the same?
+  duplicated_parents <- ped$ID[
+    ped$dadID == ped$momID &
+      !is.na(ped$dadID) & !is.na(ped$momID)
+  ]
+
+  # get the total number of within row duplicates
+  total <- length(is_own_father) + length(is_own_mother) + length(duplicated_parents)
+
+  if (verbose) {
+    if (total > 0) {
+      cat(total, " within row duplicates found.\n")
+      if (length(is_own_father) > 0) cat(length(is_own_father), " individuals are their own fathers.\n")
+      if (length(is_own_mother) > 0) cat(length(is_own_mother), " individuals are their own mothers.\n")
+      if (length(duplicated_parents) > 0) cat(length(duplicated_parents), " individuals have the same mother and father.\n")
+    } else {
+      cat("No within row duplicates found.\n")
+    }
+  }
+  # Update the validation_results list
+  list(
+    total_own_father = length(is_own_father),
+    total_own_mother = length(is_own_mother),
+    total_duplicated_parents = length(duplicated_parents),
+    total_within_row_duplicates = total,
+    within_row_duplicates = total > 0,
+    is_own_father_ids = if (length(is_own_father) > 0) unique(is_own_father) else NULL,
+    is_own_mother_ids = if (length(is_own_mother) > 0) unique(is_own_mother) else NULL,
+    duplicated_parents_ids = if (length(duplicated_parents) > 0) unique(duplicated_parents) else NULL
+  )
+}