diff --git a/DESCRIPTION b/DESCRIPTION index c434d854..3f043155 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: BGmisc Title: An R Package for Extended Behavior Genetics Analysis -Version: 1.8.0 +Version: 1.8.0.9 Authors@R: c( person("S. Mason", "Garrison", , "garrissm@wfu.edu", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-4804-6003")), diff --git a/NAMESPACE b/NAMESPACE index 86ddec85..de1c947c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,12 @@ # Generated by roxygen2: do not edit by hand export(SimPed) +export(addMaternalChain) +export(addMaternalLineFlag) +export(addParentalChain) +export(addParentalLineFlag) +export(addPaternalChain) +export(addPaternalLineFlag) export(addPersonToPed) export(alignPhenToMatrix) export(buildFamilyGroups) @@ -73,6 +79,9 @@ export(vech) importFrom(Matrix,Diagonal) importFrom(Matrix,sparseMatrix) importFrom(data.table,as.data.table) +importFrom(igraph,V) +importFrom(igraph,distances) +importFrom(igraph,subcomponent) importFrom(stats,na.omit) importFrom(stats,pnorm) importFrom(stats,qnorm) diff --git a/NEWS.md b/NEWS.md index d86e48ff..3388d9fd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,8 +1,17 @@ # BGmisc NEWS + +## Development version + +* Add building of parental chains with `addParentalChain()` and `addParentalFlag()`, so that you can easily trace maternity and paternity. This is implemented as a general function that can be used to build any parental chain, and a specific wrapper for maternal and paternal chains. The parental flag is a binary variable that indicates whether the individual is in the specified parental chain, which can be useful for filtering or grouping individuals based on their lineage. +* Fixed silent mis-scoring in `ped2com()`/`ped2add()` (and other component wrappers) when `momID`/`dadID` reference a parent ID that has no row of its own in `ped` (e.g., unrecorded founder stock, or a pedigree subset that excludes the parent's own row). Previously, `isChild_method = "partialparent"` treated such a parent as "known" (based on `momID`/`dadID` not being `NA`) while the adjacency builders correctly treated the link as absent, so the diagonal was silently understated (e.g., 0.5/0.75 instead of 1) and covariance between siblings who shared the missing parent was lost entirely. `ped2com()` now warns when this is detected. Two solutions are available in the new `repair_rowless_parents = TRUE` argument. + * \code{"rows"} (default) adds one placeholder founder row per unique missing parent ID (not one per affected child) to a working copy of \code{ped}, then restricts the returned matrix back to the original individuals via \code{keep_ids} unless \code{keep_ids} is already supplied. + * \code{"schur"} applies a Schur complement on the block-triangular RAM system -- for each missing parent, its already-known children define a rank-1 update (\code{v \%*\% t(v)}, where \code{v} is that parent's traced genetic contribution to every individual, computed from the existing RAM matrix) which is added to the relatedness matrix at the tcrossprod step. \code{"schur"} currently only supports \code{component = "additive"}. + ## BGmisc 1.8.0 * Optimized gedcom reader, com2links for speed and memory usage, with a focus on large pedigrees * Fixed bug in gedcom reader that resulted in document records being added to the final person in the pedigree * Added more unit tests for gedcom reader and data parser +* several improvements to the GEDCOM parsing functionality, focusing on more robust and flexible event parsing, better support for different GEDCOM versions, and enhanced usability. * Optimized sliceFamilies to be more abstract, and no longer require mtdna * Created `.require_openmx()` to make it easier to use OpenMx functions without making OpenMx a dependency * Smarter string ID handling for ped2id diff --git a/R/addParentalChain.R b/R/addParentalChain.R new file mode 100644 index 00000000..c0cad13b --- /dev/null +++ b/R/addParentalChain.R @@ -0,0 +1,367 @@ +#' This is a convenience wrapper around [addParentalChain()] with +#' `component = "dadID"`. +#' +#' @param ped A pedigree data frame. +#' @param personID Character string giving the name of the column containing +#' individual IDs. +#' @param dadID Character string giving the name of the column containing +#' paternal IDs. +#' @param momID Character string giving the name of the column containing +#' maternal IDs. +#' @param chain_col Character string giving the name of the output list-column +#' that will contain the ordered parental ancestor chain for each individual. +#' @param chain_string_col Character string giving the name of the output +#' character column that will contain the collapsed parental ancestor chain. +#' @param collapse Character string used to collapse ancestor IDs into +#' `chain_string_col`. +#' @param traversal_direction Character giving the mode of transversion: defaults to "in". If set to out, will procedure a list of descendants. +#' +#' @return A data frame with two added columns: +#' \describe{ +#' \item{`chain_col`}{A list-column containing the ordered paternal ancestor +#' chain for each individual.} +#' \item{`chain_string_col`}{A character column containing the collapsed +#' paternal ancestor chain, or `NA_character_` when no paternal ancestors are +#' found.} +#' } +#' +#' @export +addPaternalChain <- function( + ped, + personID = "personID", + dadID = "dadID", + momID = "momID", + chain_col = "dadID_chain", + chain_string_col = "dadID_chain_string", + collapse = "|", + traversal_direction = "in" +) { + addParentalChain( + ped = ped, + personID = personID, + dadID = dadID, + momID = momID, + chain_col = chain_col, + chain_string_col = chain_string_col, + collapse = collapse, + component = "dadID", + traversal_direction = traversal_direction + ) +} + +#' Add maternal ancestor chains to a pedigree +#' +#' Adds an ordered maternal ancestor chain for each individual in a pedigree. +#' The chain follows only mother-to-mother links, so the resulting chain is: +#' mother, maternal grandmother, maternal great-grandmother, and so on. +#' +#' This is a convenience wrapper around [addParentalChain()] with +#' `component = "momID"`. +#' +#' @inheritParams addPaternalChain +#' +#' @return A data frame with two added columns: +#' \describe{ +#' \item{`chain_col`}{A list-column containing the ordered maternal ancestor +#' chain for each individual.} +#' \item{`chain_string_col`}{A character column containing the collapsed +#' maternal ancestor chain, or `NA_character_` when no maternal ancestors are +#' found.} +#' } +#' +#' @export + +addMaternalChain <- function( + ped, + personID = "personID", + dadID = "dadID", + momID = "momID", + chain_col = "momID_chain", + chain_string_col = "momID_chain_string", + collapse = "|", + traversal_direction = "in" +) { + addParentalChain( + ped = ped, + personID = personID, + dadID = dadID, + momID = momID, + chain_col = chain_col, + chain_string_col = chain_string_col, + collapse = collapse, + component = "momID", + traversal_direction = traversal_direction + ) +} +#' Add unilineal parental ancestor chains to a pedigree +#' +#' Adds an ordered unilineal parental ancestor chain for each individual in a +#' pedigree. The chain can follow either paternal links only or maternal links +#' only. +#' +#' For `component = "dadID"`, the chain follows: +#' father, paternal grandfather, paternal great-grandfather, and so on. +#' +#' For `component = "momID"`, the chain follows: +#' mother, maternal grandmother, maternal great-grandmother, and so on. +#' +#' The function constructs a parent-specific version of the pedigree, converts it +#' to a graph using [ped2graph()], identifies reachable ancestors for each +#' individual, orders those ancestors by graph distance from the focal +#' individual, and adds both a list-column representation and a collapsed string +#' representation to the original pedigree. +#' +#' @inheritParams addPaternalChain +#' @param component Character string specifying which parental component to +#' follow. Must be either `"dadID"` for paternal chains or `"momID"` for +#' maternal chains. +#' +#' @return A data frame with two added columns: +#' \describe{ +#' \item{`chain_col`}{A list-column containing the ordered unilineal parental +#' ancestor chain for each individual.} +#' \item{`chain_string_col`}{A character column containing the collapsed +#' ancestor chain, or `NA_character_` when no ancestors are found in the +#' selected component.} +#' } +#' +#' @details +#' All pedigree IDs used to construct the parent-specific graph are coerced to +#' character. Individuals that are not represented as graph vertices receive an +#' empty chain in `chain_col` and `NA_character_` in `chain_string_col`. +#' +#' The ordering of each chain is based on graph distance from the focal +#' individual, where distance 1 is the selected parent, distance 2 is the +#' selected parent's same-component parent, and so forth. +#' +#' @importFrom igraph V subcomponent distances +#' +#' @export + +addParentalChain <- function( + ped, + personID = "personID", + dadID = "dadID", + momID = "momID", + chain_col = "chain", + chain_string_col = "chain_string", + collapse = "|", + component = c("dadID", "momID"), + traversal_direction = "in" +) { + # Build a paternal-only version of the pedigree. + # This removes maternal edges so the resulting graph only represents: + # person -> father -> father's father -> father's father's father. + + component <- match.arg(component) + + if (component == "momID") { + ############## + # Maternal-only pedigree. + ############## + parental_ped <- + data.frame( + personID = as.character(ped[[personID]]), + momID = as.character(ped[[momID]]), + dadID = NA_character_, + stringsAsFactors = FALSE + ) + } else if (component == "dadID") { + ############## + # Paternal-only pedigree. + ############## + parental_ped <- data.frame( + personID = as.character(ped[[personID]]), + momID = NA_character_, + dadID = as.character(ped[[dadID]]), + stringsAsFactors = FALSE + ) + } else { + stop("unknown id supplied") + } + # Use BGmisc infrastructure to convert the paternal-only pedigree into a graph. + parental_graph <- ped2graph( + parental_ped, + personID = "personID", + momID = "momID", + dadID = "dadID" + ) + + # For one person, recover the ordered paternal chain from the network. + get_ordered_parental_chain <- function(id) { + id_chr <- as.character(id) + + # If the person is not represented as a graph vertex, return no chain. + if (!id_chr %in% igraph::V(parental_graph)$name) { + return(character(0)) + } + + # Find all nodes reachable from this person by following paternal edges. + reachable_ids <- igraph::subcomponent( + graph = parental_graph, + v = id_chr, + mode = traversal_direction + ) |> + names() + + # Remove the person themselves from their paternal ancestor list. + reachable_ids <- setdiff(reachable_ids, id_chr) + + # If no paternal ancestors are reachable, return no chain. + if (length(reachable_ids) == 0) { + return(character(0)) + } + + # Order ancestors by graph distance. + # Distance 1 = father. + # Distance 2 = paternal grandfather. + # Distance 3 = paternal great-grandfather. + ancestor_distances <- igraph::distances( + graph = parental_graph, + v = id_chr, + to = reachable_ids, + mode = traversal_direction + )[1, ] + + reachable_ids[order(ancestor_distances)] + } + + # Add the ordered paternal chain as a list-column. + ped[[chain_col]] <- lapply( + ped[[personID]], + get_ordered_parental_chain + ) + + # Add a readable string version for inspection. + ped[[chain_string_col]] <- vapply( + ped[[chain_col]], + function(chain) { + if (length(chain) == 0) { + return(NA_character_) + } + + paste(chain, collapse = collapse) + }, + character(1) + ) + + ped +} + +#' Add a paternal-line descendant flag to a pedigree +#' +#' Adds a logical flag indicating whether a specified anchor individual appears +#' anywhere in each person's ordered paternal ancestor chain. +#' +#' This is a convenience wrapper around [addParentalLineFlag()] with +#' `component = "dadID"`. +#' +#' @param ped A pedigree data frame containing a parental chain list-column. +#' @param anchor_id ID of the anchor individual to search for within each +#' person's parental chain. +#' @param flag_col Character string giving the name of the logical output column +#' to add to `ped`. +#' @param chain_col Character string giving the name of the list-column +#' containing ordered parental ancestor chains. +#' +#' @return A data frame with `flag_col` added. The flag is `TRUE` when +#' `anchor_id` appears in the individual's paternal chain and `FALSE` +#' otherwise. +#' +#' @export +addPaternalLineFlag <- function( + ped, + anchor_id, + flag_col, + chain_col = "dadID_chain" +) { + addParentalLineFlag( + ped = ped, + anchor_id = anchor_id, + flag_col = flag_col, + chain_col = chain_col, + component = "dadID" + ) +} + +#' Add a maternal-line descendant flag to a pedigree +#' +#' Adds a logical flag indicating whether a specified anchor individual appears +#' anywhere in each person's ordered maternal ancestor chain. +#' +#' This is a convenience wrapper around [addParentalLineFlag()] with +#' `component = "momID"`. +#' +#' @inheritParams addPaternalLineFlag +#' @return A data frame with `flag_col` added. The flag is `TRUE` when +#' `anchor_id` appears in the individual's selected parental chain and `FALSE` +#' otherwise. +#' @export + +addMaternalLineFlag <- function( + ped, + anchor_id, + flag_col, + chain_col = "momID_chain" +) { + addParentalLineFlag( + ped = ped, + anchor_id = anchor_id, + flag_col = flag_col, + chain_col = chain_col, + component = "momID" + ) +} + +#' Add a unilineal parental-line descendant flag to a pedigree +#' +#' Adds a logical flag indicating whether a specified anchor individual appears +#' anywhere in each person's ordered unilineal parental ancestor chain. +#' +#' For `component = "dadID"`, the function searches the paternal chain. +#' For `component = "momID"`, the function searches the maternal chain. +#' +#' @inheritParams addPaternalLineFlag +#' @param component Character string specifying which parental component the +#' chain represents. Must be either `"dadID"` for paternal chains or `"momID"` +#' for maternal chains. +#' +#' @return A data frame with `flag_col` added. The flag is `TRUE` when +#' `anchor_id` appears in the individual's selected parental chain and `FALSE` +#' otherwise. +#' +#' @details +#' The anchor ID is coerced to character before comparison because the chain +#' columns produced by [addParentalChain()] store graph vertex names as character +#' values. +#' +#' This function assumes that `chain_col` is a list-column in which each element +#' is a character vector of ancestor IDs. Empty chains should be represented as +#' `character(0)`. +#' +#' @export +addParentalLineFlag <- function( + ped, + anchor_id, + flag_col, + chain_col, + component = c("dadID", "momID") +) { + component <- match.arg(component) + + # Convert the anchor ID to character because the parental chain stores graph + # vertex names as character values. + anchor_id_chr <- as.character(anchor_id) + + # Create a named logical flag indicating whether the anchor appears anywhere + # in each person's ordered parental chain. + ped[[flag_col]] <- vapply( + ped[[chain_col]], + function(chain) { + anchor_id_chr %in% chain + }, + logical(1) + ) + + ped +} diff --git a/R/buildComponent.R b/R/buildComponent.R index 2455d61c..7a7425f7 100644 --- a/R/buildComponent.R +++ b/R/buildComponent.R @@ -19,6 +19,8 @@ #' @param keep_ids character vector of IDs to retain in the final relatedness matrix. When supplied, only the rows of \code{r2} corresponding to these IDs are used in the tcrossprod, so the result is a \code{length(keep_ids) x length(keep_ids)} matrix. All columns of \code{r2} are retained during the multiplication so relatedness values remain correct. IDs not found in the pedigree are silently dropped with a warning. #' @param adjacency_method character. The method to use for computing the adjacency matrix. Options are "loop", "indexed", direct or beta #' @param isChild_method character. The method to use for computing the isChild matrix. Options are "classic" or "partialparent" +#' @param repair_rowless_parents logical. If TRUE, automatically correct for parents referenced in momID/dadID that have no row of their own in \code{ped} (e.g., unrecorded founder stock), before computing relatedness. Without this, such parents are still treated as "known" for the purposes of \code{isChild_method = "partialparent"} even though their genetic contribution cannot be traced, which understates diagonal relatedness and drops covariance between siblings who share the missing parent. How the correction is applied is controlled by \code{rowless_parents_method}. Defaults to FALSE, in which case a warning is issued instead. +#' @param rowless_parents_method character. How to apply the \code{repair_rowless_parents} correction. \code{"rows"} (default) adds one placeholder founder row per unique missing parent ID (not one per affected child) to a working copy of \code{ped}, then restricts the returned matrix back to the original individuals via \code{keep_ids} unless \code{keep_ids} is already supplied. \code{"schur"} applies a Schur complement on the block-triangular RAM system -- for each missing parent, its already-known children define a rank-1 update (\code{v \%*\% t(v)}, where \code{v} is that parent's traced genetic contribution to every individual, computed from the existing RAM matrix) which is added to the relatedness matrix at the tcrossprod step. \code{"schur"} currently only supports \code{component = "additive"}. #' @param adjBeta_method numeric The method to use for computing the building the adjacency_method matrix when using the "beta" build #' @param compress logical. If TRUE, use compression when saving the checkpoint files. Defaults to TRUE. #' @param mz_twins logical. If TRUE, merge MZ co-twin columns in the r2 matrix before tcrossprod so that MZ twins are coded with relatedness 1 instead of 0.5. Twin pairs are identified from the \code{twinID} column. When a \code{zygosity} column is also present, only pairs where both members have \code{zygosity == "MZ"} are used; otherwise all \code{twinID} pairs are assumed to be MZ. Defaults to TRUE. @@ -41,6 +43,8 @@ ped2com <- function(ped, component, keep_ids = NULL, adjacency_method = "direct", isChild_method = "partialparent", + repair_rowless_parents = FALSE, + rowless_parents_method = "rows", saveable = FALSE, resume = FALSE, save_rate = 5, @@ -71,6 +75,8 @@ ped2com <- function(ped, component, transpose_method = transpose_method, adjacency_method = adjacency_method, isChild_method = isChild_method, + repair_rowless_parents = repair_rowless_parents, + rowless_parents_method = rowless_parents_method, save_rate = save_rate, save_rate_gen = save_rate_gen, save_rate_parlist = save_rate_parlist, @@ -133,11 +139,76 @@ ped2com <- function(ped, component, )) } + # Validate the 'rowless_parents_method' argument + rowless_parents_method_options <- c("rows", "schur") + if (!config$rowless_parents_method %in% rowless_parents_method_options) { + stop(paste0( + "Invalid rowless_parents_method specified. Choose from ", + paste(rowless_parents_method_options, collapse = ", "), "." + )) + } + # "schur" is a pure argument-compatibility constraint, checked here for the + # same reason adjacency_method/transpose_method are validated up front -- + # this is NOT the correction itself running early. Components that return + # before the tcrossprod step (generation/distance/common nuclear) would + # otherwise never reach the check below and silently skip the correction. + if (isTRUE(config$repair_rowless_parents) && config$rowless_parents_method == "schur" && + config$component != "additive") { + stop( + "repair_rowless_parents = TRUE with rowless_parents_method = \"schur\" is currently ", + "only implemented for component = \"additive\". Use rowless_parents_method = \"rows\" ", + "for other components." + ) + } + # standardize colnames if (config$standardize_colnames == TRUE) { ped <- standardizeColnames(ped, verbose = config$verbose) } + # Detect parents referenced in momID/dadID that have no row of their own + # (e.g., unrecorded founder stock). Left unrepaired, isChild_method = + # "partialparent" (based on raw NA-status of momID/dadID) and the adjacency + # builders (based on actual row matches) disagree about whether such a + # parent is "known," which understates diagonal relatedness and silently + # drops covariance between siblings who share the same missing parent. + # rowless_parents_method = "rows" is handled entirely here, since it must + # mutate `ped` before anything downstream (isPar/isChild/RAM tracing) runs. + # rowless_parents_method = "schur" touches nothing here -- it needs the RAM + # matrix `r`, so its validation and correction both live at the tcrossprod + # step below, right where the relatedness matrix is actually assembled. + rowless_parents <- .findRowlessParents(ped) + if (length(rowless_parents) > 0) { + if (isTRUE(config$repair_rowless_parents) && config$rowless_parents_method == "rows") { + if (config$verbose == TRUE) { + message( + length(rowless_parents), " parent ID(s) referenced in momID/dadID have no row in `ped`. ", + "Adding one placeholder founder row per missing parent before computing relatedness.\n" + ) + } + original_ids <- ped$ID + ped <- addRowlessParents( + ped = ped, verbose = config$verbose, + validation_results = list(female_var = NA, male_var = NA) + ) + config$nr <- nrow(ped) + if (is.null(config$keep_ids)) { + keep_ids <- original_ids + config$keep_ids <- original_ids + } + } else if (!isTRUE(config$repair_rowless_parents)) { + warning( + length(rowless_parents), " parent ID(s) referenced in momID/dadID have no matching row in `ped`. ", + "isChild_method = \"", config$isChild_method, "\" and the adjacency builders will disagree about ", + "whether these parents are \"known,\" which can understate diagonal relatedness (e.g., 0.5/0.75 ", + "instead of 1) and omit covariance between siblings who share the missing parent. Set ", + "repair_rowless_parents = TRUE (with rowless_parents_method = \"rows\" or \"schur\") to correct ", + "for them, or repair `ped` yourself first with checkParentIDs(ped, repair = TRUE, parentswithoutrow = TRUE).", + call. = FALSE + ) + } + } + mz_row_pairs <- NULL mz_id_pairs <- NULL @@ -409,6 +480,44 @@ ped2com <- function(ped, component, } } } + + # --- Step 3c: Schur-complement correction for rowless parents --- + # For each parent referenced in momID/dadID with no row of its own, its + # (known) children define a rank-1 update: v = r %*% p_f, where p_f places + # `parVal` at each of that parent's children and r is the not-yet-isChild- + # scaled RAM matrix (I-A)^-1. Appending v as an extra column of r2 makes + # the upcoming tcrossprod add v %*% t(v) for free -- this is exactly the + # contribution that parent would have made had it been a real row, derived + # via a Schur complement on the block-triangular (rowless-parents-first) + # system. No row is ever added to `ped`, and the matrix's row dimension + # (and therefore dimnames) never changes. + if (length(rowless_parents) > 0 && isTRUE(config$repair_rowless_parents) && + config$rowless_parents_method == "schur") { + # component compatibility already validated up front + if (config$verbose == TRUE) { + message( + length(rowless_parents), " parent ID(s) referenced in momID/dadID have no row in `ped`. ", + "Applying an exact low-rank (Schur complement) correction for them here at the tcrossprod ", + "step; `ped` and matrix dimensions are left untouched.\n" + ) + } + p_nf <- matrix(0, + nrow = config$nr, ncol = length(rowless_parents), + dimnames = list(NULL, rowless_parents) + ) + for (j in seq_along(rowless_parents)) { + f <- rowless_parents[j] + p_nf[, j] <- parVal * ( + (!is.na(ped$momID) & ped$momID == f) + (!is.na(ped$dadID) & ped$dadID == f) + ) + } + v <- as.matrix(r %*% p_nf) + r2 <- cbind(r2, v) + if (config$verbose == TRUE) { + message("Added ", length(rowless_parents), " rank-1 rowless-parent correction column(s) to r2") + } + } + # --- Step 4: T crossproduct --- # Subset rows of r2 to target individuals if requested. @@ -672,6 +781,10 @@ ped2com <- function(ped, component, isPar <- loadOrComputeCheckpoint( file = checkpoint_files$isPar, compute_fn = function() { + if (is.null(iss) || is.null(jss) || length(iss) == 0 || length(jss) == 0) { + warning("Cannot construct isPar matrix: iss or jss is NULL or empty.") + } + Matrix::sparseMatrix( i = iss, j = jss, x = parVal, dims = c(config$nr, config$nr), @@ -791,7 +904,7 @@ ped2com <- function(ped, component, save_rate_parlist = config$save_rate_parlist, checkpoint_files = checkpoint_files, component = config$component, - adjacency_method = config$adjacency_method, # adjacency_method, + adjacency_method = config$adjacency_method, saveable = config$saveable, resume = config$resume, save_path = config$save_path, @@ -817,6 +930,3 @@ ped2com <- function(ped, component, } list_of_adjacencies } - - - diff --git a/R/buildmxPedigrees.R b/R/buildmxPedigrees.R index d4050308..56eeb2c1 100644 --- a/R/buildmxPedigrees.R +++ b/R/buildmxPedigrees.R @@ -345,6 +345,7 @@ buildPedigreeMx <- function(model_name, vars, group_models, #' if FALSE, use \code{mxRun}. #' @param intervals Logical. If TRUE (default), compute confidence intervals for the parameters using \code{mxSE} and \code{mxCI}. #' @param extraTries Numeric. The number of extra optimization attempts to make when \code{tryhard} is TRUE. Default is 10. +#' @param runmodel Logical. If TRUE (default), the model is fitted; if FALSE, the model is returned without fitting. #' @return A fitted OpenMx model. #' @export @@ -370,7 +371,8 @@ fitPedigreeModel <- function( tryhard = TRUE, intervals = TRUE, extraTries = 10, - condenseMatrixSlots = TRUE + condenseMatrixSlots = TRUE, + runmodel = TRUE ) { .require_openmx("fitPedigreeModel") @@ -402,11 +404,16 @@ fitPedigreeModel <- function( ci = intervals, condenseMatrixSlots = FALSE # only need to condense once ) - if (tryhard == TRUE) { - fitted_model <- OpenMx::mxTryHard(pedigree_model, silent = TRUE, extraTries = extraTries, intervals = intervals) + if (runmodel == TRUE) { + if (tryhard == TRUE) { + fitted_model <- OpenMx::mxTryHard(pedigree_model, silent = TRUE, extraTries = extraTries, intervals = intervals) + } else { + fitted_model <- OpenMx::mxRun(pedigree_model, intervals = intervals) + } } else { - fitted_model <- OpenMx::mxRun(pedigree_model, intervals = intervals) + fitted_model <- pedigree_model } + fitted_model } diff --git a/R/checkParents.R b/R/checkParents.R index c5986d23..44b7b46f 100644 --- a/R/checkParents.R +++ b/R/checkParents.R @@ -135,7 +135,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, cat("Step 3: Attempting to repair missing parents...\n") } - # cat("REPAIR IN EARLY ALPHA\n") + # cat("REPAIR IN EARLY ALPHA\n") # Initialize a list to track changes made during repair changes <- list( corrected_mom_sex = character(0), @@ -290,6 +290,20 @@ repairParentIDs <- function(ped, verbose = FALSE, ) } +#' Find Rowless Parents +#' +#' Identifies IDs referenced in momID or dadID that have no row of their own in \code{ped}. +#' Used to detect parents (e.g., unrecorded founder stock) whose genetic contribution +#' cannot be traced because their own ancestry is absent from the pedigree. +#' @param ped A dataframe representing the pedigree data with columns 'ID', 'dadID', and 'momID'. +#' @return A character/numeric vector of rowless parent IDs (empty if none). +#' @keywords internal +.findRowlessParents <- function(ped) { + all_parents <- unique(c(ped$momID, ped$dadID)) + all_parents <- all_parents[!is.na(all_parents)] + all_parents[!all_parents %in% ped$ID] +} + #' Add addRowlessParents #' #' This function adds parents who appear in momID or dadID but are missing from ID diff --git a/R/helpBuildComponent.R b/R/helpBuildComponent.R index e1db30cd..2cdf8406 100644 --- a/R/helpBuildComponent.R +++ b/R/helpBuildComponent.R @@ -3,11 +3,11 @@ #' @keywords internal initializeCheckpoint <- function(config = list( - verbose = FALSE, - saveable = FALSE, - resume = FALSE, - save_path = "checkpoint/" -)) { + verbose = FALSE, + saveable = FALSE, + resume = FALSE, + save_path = "checkpoint/" + )) { # Define checkpoint files # Ensure save path exists if (config$saveable == TRUE && !dir.exists(config$save_path)) { diff --git a/R/helpReadGedcom.R b/R/helpReadGedcom.R index ace867a1..eec51cdc 100644 --- a/R/helpReadGedcom.R +++ b/R/helpReadGedcom.R @@ -18,7 +18,7 @@ initializeRecord <- function(all_var_names) { #' @param df_temp A data frame containing the columns to be combined. #' @return A data frame with the combined columns. collapseNames <- function(verbose, df_temp) { - if (verbose == TRUE) message("Combining Duplicate Columns") + if (verbose == TRUE) message("Combining Duplicate Name Columns...") if (!all(is.na(df_temp$name_given_pieces)) || !all(is.na(df_temp$name_given))) { result <- combineColumns(df_temp$name_given, df_temp$name_given_pieces) @@ -34,6 +34,83 @@ collapseNames <- function(verbose, df_temp) { df_temp } +#' Detect GEDCOM Version from File Lines +#' +#' @param lines Character vector of lines from a GEDCOM file. +#' @return A string such as `"5.5.1"`, `"7.0"`, or `"unknown"`. +#' @keywords internal +detectGedcomVersion <- function(lines) { + head_idx <- which(grepl("^0 HEAD\\b", lines))[1L] + if (is.na(head_idx)) { + return("unknown") + } + + # End of HEAD is the next level-0 record + if (head_idx >= length(lines)) { + return("unknown") + } + next_l0 <- which(grepl("^0 ", lines[(head_idx + 1L):length(lines)]))[1L] + head_end <- if (is.na(next_l0)) length(lines) else head_idx + next_l0 - 1L + head_block <- lines[head_idx:head_end] + + gedc_idx <- which(grepl("^1 GEDC\\b", head_block))[1L] + if (is.na(gedc_idx)) { + return("unknown") + } + + # Guard: if GEDC is the last line of HEAD, there is no VERS to look ahead to + if (gedc_idx >= length(head_block)) { + return("unknown") + } + + # Look ahead within HEAD block for the VERS line under GEDC + lookahead <- head_block[seq(gedc_idx + 1L, min(gedc_idx + 5L, length(head_block)))] + vers_line <- lookahead[grepl("^2 VERS\\b", lookahead)][1L] + if (is.na(vers_line)) { + return("unknown") + } + + val <- extractInfo(vers_line, "VERS") + if (is.na(val) || !nzchar(val)) { + return("unknown") + } + val +} + +#' Convert GEDCOM Latitude String to Numeric +#' +#' Converts GEDCOM-style latitude strings like `"N51.5074"` or `"S33.8688"` to +#' signed decimal degrees. Returns `NA` for `NA` or unrecognised-prefix input. +#' +#' @param x Character vector of GEDCOM latitude values. +#' @return Numeric vector of decimal degrees (positive = N, negative = S). +#' @examples +#' BGmisc:::gedcomLatToNumeric(c("N51.5074", "S33.8688", NA)) +#' @keywords internal +gedcomLatToNumeric <- function(x) { + out <- rep(NA_real_, length(x)) + ok <- !is.na(x) & (startsWith(x, "N") | startsWith(x, "S")) + out[ok] <- as.numeric(substring(x[ok], 2)) * ifelse(startsWith(x[ok], "N"), 1, -1) + out +} + +#' Convert GEDCOM Longitude String to Numeric +#' +#' Converts GEDCOM-style longitude strings like `"E151.2093"` or `"W0.1278"` to +#' signed decimal degrees. Returns `NA` for `NA` or unrecognised-prefix input. +#' +#' @param x Character vector of GEDCOM longitude values. +#' @return Numeric vector of decimal degrees (positive = E, negative = W). +#' @examples +#' BGmisc:::gedcomLonToNumeric(c("E151.2093", "W0.1278", NA)) +#' @keywords internal +gedcomLonToNumeric <- function(x) { + out <- rep(NA_real_, length(x)) + ok <- !is.na(x) & (startsWith(x, "E") | startsWith(x, "W")) + out[ok] <- as.numeric(substring(x[ok], 2)) * ifelse(startsWith(x[ok], "E"), 1, -1) + out +} + #' Combine Columns #' #' This function combines two columns, handling conflicts and merging non-conflicting data. diff --git a/R/readGedcom.R b/R/readGedcom.R index 92614b54..45c32d06 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -20,12 +20,14 @@ #' including name prefix, name suffix, nickname, and married surname. #' #' Birth and death events are recognized from `BIRT` and `DEAT` tags. Event -#' details are currently parsed using fixed offsets within the individual block. -#' For birth events, the parser expects `DATE` at `i + 1`, `PLAC` at `i + 2`, -#' `LATI` at `i + 4`, and `LONG` at `i + 5`. For death events, the parser -#' expects `DATE` at `i + 1`, `PLAC` at `i + 2`, `CAUS` at `i + 3`, `LATI` at -#' `i + 4`, and `LONG` at `i + 5`. Missing elements leave the corresponding -#' output fields as `NA`. +#' details are parsed by collecting all child lines whose GEDCOM level equals +#' the event level plus one (direct children), then looking up sub-fields by +#' tag name. `DATE`, `PLAC`, and `CAUS` are matched as direct children of the +#' event. Coordinates (`LATI` and `LONG`) are searched across all descendant +#' lines, which allows them to be located whether they appear as direct children +#' (common in some GEDCOM 5.5.x exporters), under `PLAC` (standard GEDCOM +#' 5.5.1), or under a `MAP` substructure under `PLAC` (GEDCOM 7.x). Missing +#' sub-fields leave the corresponding output columns as `NA`. #' #' Attribute tags such as `OCCU`, `EDUC`, `RELI`, `CAST`, `NCHI`, `NMR`, `NATI`, #' `RESI`, `PROP`, `SSN`, `TITL`, `DSCR`, and `IDNO` are parsed directly into @@ -45,20 +47,22 @@ #' #' @param file_path Character string. Path to the GEDCOM file. #' @param verbose Logical. If `TRUE`, print progress messages. -#' @param add_parents Logical. If `TRUE`, infer `momID` and `dadID` from `FAMC` -#' and `FAMS` mappings during post-processing. #' @param remove_empty_cols Logical. If `TRUE`, drop columns that are entirely #' `NA` during post-processing. -#' @param combine_cols Logical. If `TRUE`, combine redundant name columns, such -#' as `name_given` with `name_given_pieces` and `name_surn` with -#' `name_surn_pieces`, when their values do not conflict. -#' @param parse_dates Logical. If `TRUE`, attempt to parse date columns (e.g., `birth_date`, `death_date`) into Date objects, after removing common GEDCOM date qualifiers like "ABT", "BEF", and "AFT". #' @param skinny Logical. If `TRUE`, return a slimmer data frame by dropping #' `FAMC`, `FAMS`, and columns that are entirely `NA` during post-processing. #' @param update_rate Numeric. Intended rate at which progress messages should #' be printed. Currently unused. #' @param post_process Logical. If `TRUE`, apply post-processing steps controlled #' by `add_parents`, `combine_cols`, `remove_empty_cols`, `skinny`, and `parse_dates`. +#' @param remove_empty_cols Logical indicating whether to remove columns that are entirely missing. +#' @param combine_cols Logical. If `TRUE`, combine redundant name columns, such +#' as `name_given` with `name_given_pieces` and `name_surn` with +#' `name_surn_pieces`, when their values do not conflict. +#' @param add_parents Logical. If `TRUE`, infer `momID` and `dadID` from `FAMC` +#' and `FAMS` mappings during post-processing. +#' @param parse_dates Logical. If `TRUE`, attempt to parse date columns (e.g., `birth_date`, `death_date`) into Date objects, after removing common GEDCOM date qualifiers like "ABT", "BEF", and "AFT". +#' @param clean_names Logical indicating whether to clean name columns by removing trailing slashes and squishing whitespace. #' @param ... Additional arguments. Currently unused. #' @return A data frame containing information about individuals, with the following potential columns: #' \describe{ @@ -107,13 +111,14 @@ #' readGedcom <- function(file_path, verbose = FALSE, + post_process = TRUE, add_parents = TRUE, remove_empty_cols = TRUE, combine_cols = TRUE, skinny = FALSE, parse_dates = FALSE, + clean_names = TRUE, update_rate = 1000, - post_process = TRUE, ...) { # Ensure the file exists and read all lines. if (!file.exists(file_path)) { @@ -121,6 +126,8 @@ readGedcom <- function(file_path, } if (verbose == TRUE) message("Reading file: ", file_path) lines <- readLines(file_path) + gedcom_version <- detectGedcomVersion(lines) + if (verbose) message("Detected GEDCOM version: ", gedcom_version) total_lines <- length(lines) if (verbose == TRUE) message("File is ", total_lines, " lines long") @@ -163,6 +170,7 @@ readGedcom <- function(file_path, records <- Filter(Negate(is.null), records) if (length(records) == 0) { + # Returns NULL without a gedcom_version attribute; callers should check is.null() first. warning("No people found in file") return(NULL) } @@ -183,11 +191,13 @@ readGedcom <- function(file_path, combine_cols = combine_cols, parse_dates = parse_dates, add_parents = add_parents, + clean_names = clean_names, skinny = skinny, verbose = verbose ) } + attr(df_temp, "gedcom_version") <- gedcom_version df_temp } @@ -363,31 +373,85 @@ parseNameLine <- function(line, record) { record } +extractGedcomLevel <- function(line) { + as.integer(stringr::str_extract(line, "^\\d+")) +} + +extractEventSubBlock <- function(block, start_idx) { + event_level <- extractGedcomLevel(block[start_idx]) + n <- length(block) + # start_idx is always within bounds because it comes from a bounded loop in the caller, + # but guard defensively to avoid the descending-sequence pitfall of R's : operator. + if (start_idx >= n) { + return(character(0)) + } + end_idx <- start_idx + for (j in (start_idx + 1L):n) { + lvl <- extractGedcomLevel(block[j]) + if (is.na(lvl)) next + if (lvl <= event_level) break + end_idx <- j + } + if (end_idx == start_idx) { + return(character(0)) + } + block[(start_idx + 1L):end_idx] +} + +extractInfoFromLines <- function(lines, tag) { + pattern <- paste0("\\b", tag, "\\b") + matches <- lines[grepl(pattern, lines)] + if (length(matches) == 0L) { + return(NA_character_) + } + extractInfo(matches[1L], tag) +} + +extractCoordFromSubBlock <- function(sub_block, tag) { + # Searches all levels of the sub-block so it handles: + # GEDCOM 5.5.x: LATI/LONG as direct children of the event + # GEDCOM 5.5.x standard: LATI/LONG under PLAC (level+2) + # GEDCOM 7.x: LATI/LONG under MAP under PLAC (level+3) + pattern <- paste0("\\b", tag, "\\b") + matches <- sub_block[grepl(pattern, sub_block)] + if (length(matches) == 0L) { + return(NA_character_) + } + extractInfo(matches[1L], tag) +} + #' Process Event Lines (Birth or Death) #' #' @description Extracts event details (e.g., date, place, cause, latitude, longitude) from a block of GEDCOM lines. -#' For "birth": expect DATE on line i+1, PLAC on i+2, LATI on i+4, LONG on i+5. -#' For "death": expect DATE on line i+1, PLAC on i+2, CAUS on i+3, LATI on i+4, LONG on i+5. +#' Uses level-aware sub-block parsing so fields are looked up by tag name rather than fixed offsets. #' @param event A character string indicating the event type ("birth" or "death"). #' @param block A character vector of GEDCOM lines. #' @param i The current line index where the event tag is found. #' @param record A named list representing the individual's record. #' @param pattern_rows A list with counts of GEDCOM tag occurrences. -#' @return The updated record with parsed event information.# -# For "death": expect DATE on line i+1, PLAC on i+2, CAUS on i+3, LATI on i+4, LONG on i+5. +#' @return The updated record with parsed event information. processEventLine <- function(event, block, i, record, pattern_rows) { - n_lines <- length(block) + sub_block <- extractEventSubBlock(block, i) + if (length(sub_block) == 0L) { + return(record) + } + + event_level <- extractGedcomLevel(block[i]) + direct_children <- sub_block[ + vapply(sub_block, extractGedcomLevel, integer(1L)) == event_level + 1L + ] + if (event == "birth") { - if (i + 1 <= n_lines) record$birth_date <- extractInfo(block[i + 1], "DATE") - if (i + 2 <= n_lines) record$birth_place <- extractInfo(block[i + 2], "PLAC") - if (i + 4 <= n_lines) record$birth_lat <- extractInfo(block[i + 4], "LATI") - if (i + 5 <= n_lines) record$birth_long <- extractInfo(block[i + 5], "LONG") + record$birth_date <- extractInfoFromLines(direct_children, "DATE") + record$birth_place <- extractInfoFromLines(direct_children, "PLAC") + record$birth_lat <- extractCoordFromSubBlock(sub_block, "LATI") + record$birth_long <- extractCoordFromSubBlock(sub_block, "LONG") } else if (event == "death") { - if (i + 1 <= n_lines) record$death_date <- extractInfo(block[i + 1], "DATE") - if (i + 2 <= n_lines) record$death_place <- extractInfo(block[i + 2], "PLAC") - if (i + 3 <= n_lines) record$death_caus <- extractInfo(block[i + 3], "CAUS") - if (i + 4 <= n_lines) record$death_lat <- extractInfo(block[i + 4], "LATI") - if (i + 5 <= n_lines) record$death_long <- extractInfo(block[i + 5], "LONG") + record$death_date <- extractInfoFromLines(direct_children, "DATE") + record$death_place <- extractInfoFromLines(direct_children, "PLAC") + record$death_caus <- extractInfoFromLines(direct_children, "CAUS") + record$death_lat <- extractCoordFromSubBlock(sub_block, "LATI") + record$death_long <- extractCoordFromSubBlock(sub_block, "LONG") } record } @@ -410,8 +474,11 @@ processEventLine <- function(event, block, i, record, pattern_rows) { applyTagMappings <- function(line, record, pattern_rows, tag_mappings) { for (mapping in tag_mappings) { extractor <- if (is.null(mapping$extractor)) NULL else mapping$extractor - result <- processTag(mapping$tag, mapping$field, pattern_rows, line, record, - extractor = extractor, mode = mapping$mode + result <- processTag(mapping$tag, + mapping$field, + pattern_rows, line, record, + extractor = extractor, + mode = mapping$mode ) record <- result$vars if (result$matched) { @@ -512,8 +579,10 @@ processTag <- function(tag, vars, extractor = NULL, mode = "replace") { - count_name <- paste0("num_",# normalize leading underscores - tolower(gsub("^_", "", tag)), "_rows") + count_name <- paste0( + "num_", # normalize leading underscores + tolower(gsub("^_", "", tag)), "_rows" + ) matched <- FALSE if (!is.null(pattern_rows[[count_name]]) && pattern_rows[[count_name]] > 0 && @@ -537,20 +606,16 @@ processTag <- function(tag, #' #' @description This function optionally adds parent information, combines duplicate columns, #' and removes empty columns from the GEDCOM data frame. It is called by \code{readGedcom()} if \code{post_process = TRUE}. -#' +#' @inheritParams readGedcom #' @param df_temp A data frame produced by \code{readGedcom()}. -#' @param remove_empty_cols Logical indicating whether to remove columns that are entirely missing. -#' @param combine_cols Logical indicating whether to combine columns with duplicate values. -#' @param add_parents Logical indicating whether to add parent information. -#' @param parse_dates Logical indicating whether to parse date columns into Date objects. -#' @param skinny Logical indicating whether to slim down the data frame. #' @param verbose Logical indicating whether to print progress messages. #' @return The post-processed data frame. postProcessGedcom <- function(df_temp, remove_empty_cols = TRUE, combine_cols = TRUE, - parse_dates = FALSE, add_parents = TRUE, + parse_dates = FALSE, + clean_names = TRUE, skinny = TRUE, verbose = FALSE) { if (add_parents == TRUE) { @@ -564,30 +629,53 @@ postProcessGedcom <- function(df_temp, if (verbose == TRUE) message("Removing empty columns") df_temp <- df_temp[, colSums(is.na(df_temp)) < nrow(df_temp)] } - if(parse_dates == TRUE) { + if (parse_dates == TRUE) { + date_cols <- c("birth_date", "death_date") + calendar_escape_regex <- "@#D[A-Z ]+@\\s*" + date_qualifier_regex <- "\\b(?:[aA][bBfF][tT]|[bB][eE][tTfF])\\.?\\b\\s*" - date_cols <- c("birth_date", "death_date") - if (verbose == TRUE) message("Parsing date columns: ", paste(date_cols[date_cols %in% colnames(df_temp)], collapse = ", ")) - # GEDCOM date qualifiers like "ABT", "BEF", "AFT" can be present in date strings. We can remove them before parsing. - date_qualifier_regex <- "\\b(?:[aA][bBfF][tT]|[bB][eE][tTfF])\\.?\\b\\s*" + if (verbose == TRUE) { + message("Parsing date columns: ", paste(date_cols[date_cols %in% colnames(df_temp)], collapse = ", ")) + } - if(verbose == TRUE && any(sapply(df_temp[date_cols], function(col) any(grepl(date_qualifier_regex, col, perl = TRUE)))) - ) { - message("Found date qualifiers in date columns. They will be removed before parsing.") - } + if (verbose == TRUE && any(date_cols %in% colnames(df_temp))) { + has_qualifiers <- any(sapply( + df_temp[date_cols[date_cols %in% colnames(df_temp)]], + function(col) any(grepl(date_qualifier_regex, col, perl = TRUE)) + )) + if (has_qualifiers == TRUE) { + message("Found date qualifiers in date columns. They will be removed before parsing.") + } + } - # only parse date columns that are present in the data frame - if (any(date_cols %in% colnames(df_temp))) { - df_temp[date_cols] <- lapply(df_temp[date_cols], function(x) { - if (is.character(x)) { - x <- stringr::str_replace_all(x, date_qualifier_regex, "") - as.Date(x, format = "%d %b %Y") + # only parse date columns that are present in the data frame + present_date_cols <- date_cols[date_cols %in% colnames(df_temp)] + if (length(present_date_cols) > 0) { + df_temp[present_date_cols] <- lapply(df_temp[present_date_cols], function(x) { + if (is.character(x)) { + x <- stringr::str_replace_all(x, calendar_escape_regex, "") + x <- stringr::str_replace_all(x, date_qualifier_regex, "") + as.Date(stringr::str_trim(x), format = "%d %b %Y") + } else { + x + } + }) + } + } + if (clean_names == TRUE) { + if (verbose == TRUE) message("Cleaning column names") + name_cols <- grep("^name", colnames(df_temp), value = TRUE) + if (verbose == TRUE && any(name_cols %in% colnames(df_temp))) { + message("Cleaning name columns: ", paste(name_cols, collapse = ", ")) + } + df_temp[name_cols] <- lapply(df_temp[name_cols], function(x) { + if (is.character(x)) { # remove / at end of names if present, and squish whitespace + stringr::str_squish(stringr::str_replace(x, "/+$", "")) } else { x } }) -} -} + } if (skinny == TRUE) { if (verbose == TRUE) message("Slimming down the data frame") # Remove raw family relationship columns @@ -605,8 +693,7 @@ postProcessGedcom <- function(df_temp, #' @param datasource Character string indicating the data source ("gedcom" or "wiki"). #' @param person_id_col Character string indicating the column name for individual IDs (default "personID"). #' @return The updated data frame with parent IDs added. -processParents <- function(df_temp, datasource, person_id_col = "personID" - ) { +processParents <- function(df_temp, datasource, person_id_col = "personID") { if (datasource %in% c("gedcom", "ged")) { required_cols <- c("FAMC", "sex", "FAMS") } else if (datasource == "wiki") { @@ -638,8 +725,7 @@ processParents <- function(df_temp, datasource, person_id_col = "personID" #' @return A list mapping family IDs to parent information. mapFAMS2parents <- function(df_temp, mom_sex = "F", - dad_sex = "M" - ) { + dad_sex = "M") { if (!all(c("FAMS", "sex") %in% colnames(df_temp))) { warning("The data frame does not contain the necessary columns (FAMS, sex)") return(NULL) @@ -700,7 +786,6 @@ mapFAMC2parents <- function(df_temp, family_to_parents) { } - # --- Exported Aliases --- #' @rdname readGedcom #' @export diff --git a/R/simulatePedigreeBetween.R b/R/simulatePedigreeBetween.R index 7fdd0f29..397aa102 100644 --- a/R/simulatePedigreeBetween.R +++ b/R/simulatePedigreeBetween.R @@ -42,41 +42,41 @@ buildBtwnGenerations <- function(df_Fam, Ngen, sizeGens, verbose = FALSE, marR, stop("Invalid value for parameter 'beta'. Accepted values are TRUE, FALSE, 'optimized', 'base', 'original', or 'index'/'indexed'.") } -# if (use_optimized) { -# df_Fam <- buildBtwnGenerations_opt( -# df_Fam = df_Fam, -# Ngen = Ngen, -# sizeGens = sizeGens, -# verbose = verbose, -# marR = marR, -# sexR = sexR, -# kpc = kpc, -# rd_kpc = rd_kpc, - # personID = personID, - # momID = momID, - # dadID = dadID, -# code_male = code_male, - # code_female = code_female, - # beta = TRUE -# ) -# } else { - df_Fam <- buildBtwnGenerations_base( - df_Fam = df_Fam, - Ngen = Ngen, - sizeGens = sizeGens, - verbose = verbose, - marR = marR, - sexR = sexR, - kpc = kpc, - rd_kpc = rd_kpc, - personID = personID, - momID = momID, - dadID = dadID, - code_male = code_male, - code_female = code_female, - beta = FALSE - ) -# } + # if (use_optimized) { + # df_Fam <- buildBtwnGenerations_opt( + # df_Fam = df_Fam, + # Ngen = Ngen, + # sizeGens = sizeGens, + # verbose = verbose, + # marR = marR, + # sexR = sexR, + # kpc = kpc, + # rd_kpc = rd_kpc, + # personID = personID, + # momID = momID, + # dadID = dadID, + # code_male = code_male, + # code_female = code_female, + # beta = TRUE + # ) + # } else { + df_Fam <- buildBtwnGenerations_base( + df_Fam = df_Fam, + Ngen = Ngen, + sizeGens = sizeGens, + verbose = verbose, + marR = marR, + sexR = sexR, + kpc = kpc, + rd_kpc = rd_kpc, + personID = personID, + momID = momID, + dadID = dadID, + code_male = code_male, + code_female = code_female, + beta = FALSE + ) + # } df_Fam } @@ -459,5 +459,4 @@ buildBtwnGenerations_base <- function(df_Fam, df_Fam } -#buildBtwnGenerations_opt <- buildBtwnGenerations_base - +# buildBtwnGenerations_opt <- buildBtwnGenerations_base diff --git a/R/sysdata.rda b/R/sysdata.rda new file mode 100644 index 00000000..3101c76d Binary files /dev/null and b/R/sysdata.rda differ diff --git a/_pkgdown.yml b/_pkgdown.yml index fbd085d6..5c962523 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -1,3 +1,16 @@ url: https://r-computing-lab.github.io/BGmisc template: bootstrap: 5 + +reference: + - title: GEDCOM I/O + contents: + - readGedcom + - readGed + - readgedcom + - gedcomLatToNumeric + - gedcomLonToNumeric + + - title: Other functions + contents: + - matches(".*") diff --git a/data-raw/benchmark_rowlessParents.R b/data-raw/benchmark_rowlessParents.R new file mode 100644 index 00000000..0cfb60cd --- /dev/null +++ b/data-raw/benchmark_rowlessParents.R @@ -0,0 +1,126 @@ +library(microbenchmark) +library(Matrix) +library(BGmisc) +library(tidyverse) + +# Build a pedigree, then strip out some founder rows so their IDs become +# "rowless parents" -- referenced in momID/dadID but with no row of their +# own -- to benchmark rowless_parents_method = "rows" vs "schur" against +# each other, the same way benchmark.R compares adjacency_method values. +makeRowlessPed <- function(kpc, Ngen, sexR = .5, marR = .7, seed = 1, drop_frac = 0.2, full = FALSE) { + set.seed(seed) + ped <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) + + if (full) { + return(ped) + } + founder_ids <- ped$ID[is.na(ped$momID) & is.na(ped$dadID)] + n_drop <- floor(drop_frac * length(founder_ids)) + drop_ids <- sample(founder_ids, n_drop) + + ped[!ped$ID %in% drop_ids, ] +} +ped_small_complete <- makeRowlessPed(kpc = 3, Ngen = 5, seed = 15, full = TRUE) +ped_big_complete <- makeRowlessPed(kpc = 8, Ngen = 5, seed = 1151, full = TRUE) +ped_small <- makeRowlessPed(kpc = 3, Ngen = 5, seed = 15) +ped_big <- makeRowlessPed(kpc = 8, Ngen = 5, seed = 1151) + + +cat("small: n =", nrow(ped_small), ", rowless parents =", length(.findRowlessParents(standardizeColnames(ped_small))), "\n") +cat("big: n =", nrow(ped_big), ", rowless parents =", length(.findRowlessParents(standardizeColnames(ped_big))), "\n") + +component <- "additive" +verbose <- FALSE +saveable <- FALSE +resume <- FALSE + +benchmark_results <- microbenchmark( + rows_small = { + ped2com( + ped = ped_small, component = component, + repair_rowless_parents = TRUE, rowless_parents_method = "rows", + saveable = saveable, resume = resume, verbose = verbose, sparse = FALSE + ) + }, + base_small = { + ped2com( + ped = ped_small_complete, component = component, + repair_rowless_parents = F, + saveable = saveable, resume = resume, verbose = verbose, sparse = FALSE + ) + }, + schur_small = { + ped2com( + ped = ped_small, component = component, + repair_rowless_parents = TRUE, rowless_parents_method = "schur", + saveable = saveable, resume = resume, verbose = verbose, sparse = FALSE + ) + }, + rows_big = { + ped2com( + ped = ped_big, component = component, + repair_rowless_parents = TRUE, rowless_parents_method = "rows", + saveable = saveable, resume = resume, verbose = verbose, sparse = FALSE + ) + }, + base_big = { + ped2com( + ped = ped_big_complete, component = component, + repair_rowless_parents = F, + saveable = saveable, resume = resume, verbose = verbose, sparse = FALSE + ) + }, + schur_big = { + ped2com( + ped = ped_big, component = component, + repair_rowless_parents = TRUE, rowless_parents_method = "schur", + saveable = saveable, resume = resume, verbose = verbose, sparse = FALSE + ) + }, + times = 20 +) + +summary(benchmark_results) + +df_plot <- benchmark_results %>% mutate( + size = case_when( + expr %in% c( + "rows_small", "schur_small", + "base_small" + ) ~ "small", + expr %in% c( + "rows_big", "schur_big", + "base_big" + ) ~ "big" + ), + method = case_when( + expr %in% c("rows_small", "rows_big") ~ "rows", + expr %in% c("schur_small", "schur_big") ~ "schur", + expr %in% c("base_small", "base_big") ~ "base" + ) +) + +df_plot$method <- factor(df_plot$method, levels = c("rows", "schur", "base")) +df_plot$size <- factor(df_plot$size, levels = c("small", "big")) + +lm(time ~ method * size, data = df_plot) %>% + summary() %>% + print() + +p <- ggplot(df_plot, aes(x = method, y = time)) + + geom_boxplot(aes(fill = size), alpha = 0.5) + + labs( + title = "Rowless-Parent Correction: rows vs schur", + x = "Method", + y = "Time (nanoseconds)" + ) + + theme_minimal() + + theme(axis.text.x = element_text(angle = 45, hjust = 1)) + +p +print(benchmark_results) + +write.csv(summary(benchmark_results), + "benchmark_rowlessParents_results.csv", + row.names = FALSE +) diff --git a/data-raw/df_royal92.R b/data-raw/df_royal92.R index 64ce6d2f..864f5a8c 100644 --- a/data-raw/df_royal92.R +++ b/data-raw/df_royal92.R @@ -25,12 +25,11 @@ strip_date_qualifier <- function(x) { } standardize_partial_date <- function(x, default_day = "15", - default_month = "JUN" - ) { + default_month = "JUN") { case_when( str_length(x) == 0 ~ NA_character_, - str_length(x) %in% c(3,4) ~ paste0(default_day," ",default_month," ", x), - str_length(x) %in% c(7,8) ~ paste0(default_day," ", x), + str_length(x) %in% c(3, 4) ~ paste0(default_day, " ", default_month, " ", x), + str_length(x) %in% c(7, 8) ~ paste0(default_day, " ", x), TRUE ~ x ) } @@ -94,7 +93,7 @@ royal92 <- df_raw <- readGedcom("data-raw/royal92.ged") %>% momID = 1295, dadID = 1294, overwrite = TRUE - ) %>% + ) %>% addPersonToPed( personID = 1582, name = "Sanchia of Provence", @@ -102,29 +101,37 @@ royal92 <- df_raw <- readGedcom("data-raw/royal92.ged") %>% momID = 1884, dadID = 1881, overwrite = TRUE - ) %>% + ) %>% addPersonToPed( personID = 1884, name = "Beatrice of Savoy", sex = "F", momID = NA_integer_, - dadID = NA_integer_, + dadID = NA_integer_, overwrite = TRUE - ) %>% + ) %>% addPersonToPed( personID = 2149, name = "Helen Louise Kirby", sex = "F", momID = 589, - dadID = 235, + dadID = 235, overwrite = TRUE - ) %>% + ) %>% addPersonToPed( personID = 1051, # overwriting duplicated Andreas, is already 911 name = "TODO", sex = "U", momID = NA_integer_, - dadID = NA_integer_, + dadID = NA_integer_, + overwrite = TRUE + ) %>% + addPersonToPed( + personID = 1125, # overwriting duplicated Jean of Luxembourg + name = "TODO", + sex = "U", + momID = NA_integer_, + dadID = NA_integer_, overwrite = TRUE ) %>% addPersonToPed( @@ -132,20 +139,19 @@ royal92 <- df_raw <- readGedcom("data-raw/royal92.ged") %>% name = "TODO", sex = "U", momID = NA_integer_, - dadID = NA_integer_, + dadID = NA_integer_, overwrite = TRUE - )%>% + ) %>% addPersonToPed( personID = 3009, # overwriting unnamed stillborn sibling of barbara cartland name = "TODO", sex = "U", momID = NA_integer_, - dadID = NA_integer_, + dadID = NA_integer_, overwrite = TRUE ) - #---- # Create overrides for dates and names based on historical records and data cleaning needs #---- @@ -163,27 +169,27 @@ date_overrides <- tribble( 34, "31 MAR 1900", "10 JUN 1974", # Henry William Frederick Windsor 38, "5 APR 1863", "24 SEP 1950", # Victoria Alberta of Hesse 40, "10 MAR 1845", "1 NOV 1894", # Alexander III Alexandrovich Romanov, - # Old Style = 26 FEB 1845, 20 OCT 1894 + # Old Style = 26 FEB 1845, 20 OCT 1894 41, "26 NOV 1847", "13 OCT 1928", # Dagmar (Marie) of Denmark 42, "6 JUL 1796", "2 MAR 1855", # Nicholas I Romanov, - # Old Style = 25 JUN 1796, 18 FEB 1855 + # Old Style = 25 JUN 1796, 18 FEB 1855 43, "13 JUL 1798", "1 NOV 1860", # Charlotte of Prussia 44, "29 APR 1818", "13 MAR 1881", # Alexander II Nicholoevich Romanov, - # Gregorian/New Style; Old Style = 17 APR 1818, 1 MAR 1881 + # Gregorian/New Style; Old Style = 17 APR 1818, 1 MAR 1881 45, "8 AUG 1824", "3 JUN 1880", # Marie of Hesse-Darmstadt 46, "15 NOV 1895", "17 JUL 1918", # Olga Nikolaevna Romanov, - # Old Style birth = 2 NOV 1895 + # Old Style birth = 2 NOV 1895 47, "10 JUN 1897", "17 JUL 1918", # Tatiana Nikolaevna Romanov, - # Old Style birth = 29 May 1897 + # Old Style birth = 29 May 1897 48, "26 JUN 1899", "17 JUL 1918", # Maria Nikolaevna Romanov, - # Old Style birth = 14 JUN 1899 + # Old Style birth = 14 JUN 1899 49, "18 JUN 1901", "17 JUL 1918", # Anastasia Nikolaevna Romanov, - # Old Style birth = 5 Jun 1901 - 51, "4 AUG 1900", "30 MAR 2002", #Elizabeth Angela Marguerite Bowes-Lyon + # Old Style birth = 5 Jun 1901 + 51, "4 AUG 1900", "30 MAR 2002", # Elizabeth Angela Marguerite Bowes-Lyon 52, "21 APR 1926", "8 SEP 2022", # Elizabeth II Alexandra Mary Windsor 53, "21 AUG 1930", "9 FEB 2002", # Margaret Rose Windsor 54, "7 APR 1930", "13 JAN 2017", # Antony Armstrong-Jones - 57, "10 JUN 1921", "9 APR 2021", #Philip Mountbatten + 57, "10 JUN 1921", "9 APR 2021", # Philip Mountbatten 65, "1 JUL 1961", "31 AUG 1997", # Diana Frances Spencer 66, "13 DEC 1906", "27 AUG 1968", # Marina of Greece, Gregorian/New Style; Old Style birth = 30 NOV 1906 68, "9 SEP 1882", "24 MAY 1947", # Henry George Charles Lascelles @@ -228,8 +234,8 @@ date_overrides <- tribble( 125, "17 MAY 1891", "26 FEB 1959", # Alexandra, 2nd Duchess of Fife 126, "29 MAY 1881", "8 OCT 1972", # Alexander Ramsay 127, "1295", "22 AUG 1358", # Isabella of France; birth year uncertain, - # sources vary ca. 1292/1295/1296; - # death date varies by one day, 22 AUG vs 23 AUG 1358 + # sources vary ca. 1292/1295/1296; + # death date varies by one day, 22 AUG vs 23 AUG 1358 128, "15 APR 1240", "1271", # Simon de Montfort the Younger 129, "19 JUL 1884", "6 MAR 1954", # Charles Edward, Duke of Saxe-Coburg and Gotha 132, "24 FEB 1774", "8 JUL 1850", # Adolphus, Duke of Cambridge @@ -246,29 +252,29 @@ date_overrides <- tribble( 147, "18 APR 1905", "24 APR 1981", # Margarita of Greece and Denmark 148, "30 MAY 1906", "16 OCT 1969", # Theodora of Greece and Denmark 149, "22 APR 1847", "17 FEB 1909", # Vladimir Alexandrovich Romanov, - # Gregorian/New Style; - # Old Style birth = 10 APR 1847 + # Gregorian/New Style; + # Old Style birth = 10 APR 1847 150, "14 JAN 1850", "27 NOV 1908", # Alexei Alexandrovich Romanov, - # Gregorian/New Style; - # Old Style = 2 JAN 1850, 14 NOV 1908 + # Gregorian/New Style; + # Old Style = 2 JAN 1850, 14 NOV 1908 151, "11 MAY 1857", "17 FEB 1905", # Serge Alexandrovich Romanov 152, "3 OCT 1860", "28 JAN 1919", # Paul Alexandrovich Romanov 153, "9 MAY 1871", "10 JUL 1899", # George Alexandrovich Romanov 154, "6 APR 1875", "20 APR 1960", # Xenia Alexandrovna Romanov, - # Gregorian/New Style; Old Style birth = 25 MAR 1875 + # Gregorian/New Style; Old Style birth = 25 MAR 1875 155, "4 DEC 1878", "13 JUN 1918", # Michael (Mischa) Alexandrovich Romanov, New Style 156, "13 JUN 1882", "24 NOV 1960", # Olga Alexandrovna Romanov, - # Gregorian/New Style; Old Style birth = 1 JUN 1882 + # Gregorian/New Style; Old Style birth = 1 JUN 1882 157, "14 MAY 1854", "6 SEP 1920", # Maria Pavlovna the Elder, - # Gregorian/New Style; Gregorian/New Style; Old Style birth = 2 MAY 1854 + # Gregorian/New Style; Gregorian/New Style; Old Style birth = 2 MAY 1854 158, "12 OCT 1876", "12 OCT 1938", # Kirill Vladimirovich Romanov, - # Gregorian/New Style; Old Style birth = 30 SEP 1876 + # Gregorian/New Style; Old Style birth = 30 SEP 1876 159, "24 NOV 1877", "9 NOV 1943", # Boris Vladimirovich Romanov, - # Gregorian/New Style + # Gregorian/New Style 160, "14 MAY 1879", "30 OCT 1956", # Andrei Vladimirovich Romanov, - # Gregorian/New Style; Old Style birth = 2 MAY 1879 + # Gregorian/New Style; Old Style birth = 2 MAY 1879 161, "31 AUG 1872", "6 DEC 1971", # Mathilde Kschessinska, - # Gregorian/New Style; Old Style birth = 19 AUG 1872 + # Gregorian/New Style; Old Style birth = 19 AUG 1872 162, "3 AUG 1770", "7 JUN 1840", # Frederick William III of Prussia 163, "30 AUG 1870", "24 SEP 1891", # Alexandra of Greece and Denmark 164, "18 SEP 1891", "5 MAR 1942", # Dmitri Pavlovich Romanov, Gregorian/New Style @@ -277,9 +283,9 @@ date_overrides <- tribble( 167, "23 MAR 1887", "27 SEP 1967", # Felix Yussoupov 169, "10 OCT 1931", "16 MAR 2003", # Ronald Ivor Ferguson 170, "9 JUN 1937", "19 SEP 1998", # Susan Mary Wright / Susan Barrantes - #Teackle Wallis Warfield + # Teackle Wallis Warfield 171, "8 FEB 1869", "15 NOV 1896", # Teackle Wallis Warfield - 172, "30 NOV 1869", "2 NOV 1929",# Alice Montague + 172, "30 NOV 1869", "2 NOV 1929", # Alice Montague 173, "17 APR 1882", "17 OCT 1893", # Violet Hyacinth Bowes-Lyon 174, "30 AUG 1883", "8 FEB 1961", # Mary Frances Bowes-Lyon / Lady Elphinstone 175, "22 SEP 1884", "25 MAY 1949", # Patrick Bowes-Lyon, 15th Earl of Strathmore and Kinghorne @@ -334,9 +340,9 @@ date_overrides <- tribble( 264, "24 AUG 1843", "2 SEP 1907", # George FitzGeorge 265, "30 JAN 1846", "17 DEC 1922", # Adolphus FitzGeorge 266, "12 JUN 1847", "30 OCT 1933", # Augustus FitzGeorge - 267, "9 MAR 1854","10 MAR 1927", # Rosa Baring - 268, "1892", "1960", #son 1 George William Frederick FitzGeorge - 269, "1886", "1976",# daught 1 Mabel Iris FitzGeorge + 267, "9 MAR 1854", "10 MAR 1927", # Rosa Baring + 268, "1892", "1960", # son 1 George William Frederick FitzGeorge + 269, "1886", "1976", # daught 1 Mabel Iris FitzGeorge 270, "1889", "1954", # daught 2 George Daphne FitzGeorge 271, "17 OCT 1819", "30 MAY 1904", # Frederick William, Grand Duke of Mecklenburg-Strelitz 272, "22 JUL 1848", "11 JUN 1914", # Adolphus Frederick V, Grand Duke of Mecklenburg-Strelitz @@ -349,7 +355,7 @@ date_overrides <- tribble( 284, "12 JUN 1897", "23 JUN 1987", # Mary Cambridge / Duchess of Beaufort 285, "23 OCT 1899", "22 DEC 1969", # Helena Cambridge 287, "24 APR 1907", "15 APR 1928", # Rupert Cambridge, Viscount Trematon; - # note conflict: RoyalFamilyTree gives 24 AUG 1907 + # note conflict: RoyalFamilyTree gives 24 AUG 1907 289, "23 JAN 1906", "29 MAY 1994", # May Cambridge 291, "21 AUG 1924", "27 FEB 1998", # Gerald David Lascelles 292, "18 OCT 1926", "6 MAR 2014", # Marion Stein / Countess of Harewood @@ -382,7 +388,7 @@ date_overrides <- tribble( 350, "21 SEP 1788", "27 JAN 1836", # Wilhelmina of Baden 351, "26 OCT 1775", "29 NOV 1830", # John Maurice von Hauke 352, "1790", "27 AUG 1831", # Sophie la Fontaine; - # approximate birth year + # approximate birth year 353, "21 SEP 1827", "25 JAN 1892", # Constantine Nikolaievitch of Russia, Gregorian/New Style; Old Style = 9 SEP 1827, 13 JAN 1892 354, "8 JUL 1830", "6 JUL 1911", # Elizabeth Alexandra of Saxe-Altenburg / Alexandra Iosifovna 355, "27 AUG 1789", "25 NOV 1868", # Joseph of Saxe-Altenburg @@ -479,9 +485,9 @@ date_overrides <- tribble( 489, "18 APR 1865", "20 JUL 1951", # Johanna Loisinger 490, "18 AUG 1874", "22 APR 1971", # Anna of Montenegro 491, "30 AUG 1842", "10 JUL 1849", # Alexandra Alexandrovna Romanov, - # Gregorian/New Style; Old Style = 18 AUG 1842, 28 JUN 1849 + # Gregorian/New Style; Old Style = 18 AUG 1842, 28 JUN 1849 492, "20 SEP 1843", "24 APR 1865", # Nicholas Alexandrovich Romanov, - # Gregorian/New Style; Old Style = 8 SEP 1843, 12 APR 1865 + # Gregorian/New Style; Old Style = 8 SEP 1843, 12 APR 1865 493, "9 JUN 1806", "13 JUN 1877", # Louis III of Hesse 494, "28 NOV 1901", "21 FEB 1960", # Edwina Ashley / Countess Mountbatten of Burma 495, "30 AUG 1813", "25 MAY 1862", # Mathilde of Bavaria @@ -545,7 +551,7 @@ date_overrides <- tribble( 584, "23 JAN 1896", "9 JUL 1985", # Charlotte of Luxembourg 586, "5 JAN 1921", "23 APR 2019", # Jean of Luxembourg 589, "6 OCT 1914", "23 MAY 2010", # Leonide Bagration-Moukhransky, - # Gregorian/New Style; Old Style birth = 23 SEP 1914 + # Gregorian/New Style; Old Style birth = 23 SEP 1914 590, "24 APR 1608", "2 FEB 1660", # Gaston, Duke of Orléans 591, "23 JUN 1908", "20 MAR 1975", # James / Jaime, Duke of Segovia 592, "30 JUL 1936", "8 JAN 2020", # Dona Maria of Bourbon / Infanta Pilar of Spain @@ -575,7 +581,7 @@ date_overrides <- tribble( 631, "13 NOV 1848", "26 JUN 1922", # Albert I of Monaco 632, "12 JUL 1870", "9 MAY 1949", # Louis II of Monaco 634, "30 SEP 1898", "16 NOV 1977", # Charlotte, Duchess of Valentinois; - # some sources give 15 NOV 1977 + # some sources give 15 NOV 1977 635, "24 OCT 1895", "10 NOV 1964", # Pierre de Polignac 636, "31 MAY 1923", "6 APR 2005", # Rainier III of Monaco 638, "27 JAN 1805", "28 MAY 1872", # Sophie of Bavaria @@ -601,7 +607,7 @@ date_overrides <- tribble( 679, "30 OCT 1797", "29 DEC 1829", # Henrietta of Nassau-Weilburg 680, "29 JUL 1818", "20 NOV 1874", # Karl Ferdinand of Austria 682, "21 JUL 1858", "6 FEB 1929", # Maria Cristina of Austria; - # some sources give 9 FEB 1929 + # some sources give 9 FEB 1929 683, "28 NOV 1857", "25 NOV 1885", # Alfonso XII 684, "9 MAR 1776", "13 JAN 1847", # Archduke Joseph of Austria, Palatine of Hungary 685, "17 JAN 1831", "14 FEB 1903", # Elisabeth Franziska of Austria @@ -613,7 +619,7 @@ date_overrides <- tribble( 729, "24 DEC 1598", "1600", # Margaret Stuart; approximate death year 735, "26 AUG 1596", "29 NOV 1632", # Frederick V of the Palatinate 736, "14 OCT 1630", "8 JUN 1714", # Sophia of Hanover; - # sources vary 13/14 OCT 1630 + # sources vary 13/14 OCT 1630 741, "26 APR 1575", "3 JUL 1642", # Marie de Medici; birth year varies in sources, selected 1575 750, "27 MAY 1626", "6 NOV 1650", # William II of Orange 751, "21 SEP 1640", "9 JUN 1701", # Philippe I, Duke of Orléans @@ -629,7 +635,7 @@ date_overrides <- tribble( 765, "22 DEC 1617", "28 AUG 1680", # Charles I Louis, Elector Palatine 766, "17 DEC 1619", "29 NOV 1682", # Rupert of the Rhine / Duke of Cumberland 767, "16 JAN 1621", "1652", # Maurice of the Palatinate; - # death year approximate, lost at sea + # death year approximate, lost at sea 768, "5 OCT 1625", "10 MAR 1663", # Edward, Count Palatine of Simmern 769, "20 NOV 1627", "16 MAR 1686", # Charlotte of Hesse-Kassel 770, "7 SEP 1674", "14 AUG 1728", # Ernest Augustus, Duke of York and Albany @@ -864,7 +870,7 @@ date_overrides <- tribble( 1122, "15 SEP 1904", "18 MAR 1983", # Umberto II of Italy 1123, "11 OCT 1927", "10 JAN 2005", # Josephine-Charlotte of Belgium 1124, "6 JUN 1934", NA_character_, # Albert II of Belgium; living - 1125, "5 JAN 1921", "23 APR 2019", # Jean of Luxembourg; duplicate/identity match to personID 586 likely + 1125, NA_character_, NA_character_, # to replace 1126, "11 JUN 1928", "5 DEC 2014", # Fabiola de Mora y Aragón 1127, "11 SEP 1937", NA_character_, # Paola Ruffo di Calabria; living 1128, "15 APR 1960", NA_character_, # Philippe of Belgium; living @@ -1041,7 +1047,7 @@ date_overrides <- tribble( 1369, "1214", "1 DEC 1241", # Isabella of England 1370, "1215", "13 APR 1275", # Eleanor of England 1372, "1122", "1 APR 1204", # Eleanor of Aquitaine - 1373, "17 AUG 1153", "1156", #William IX, count of Poitiers + 1373, "17 AUG 1153", "1156", # William IX, count of Poitiers 1375, "1156", "28 JUN 1189", # Matilda (Maud), Duchess of Saxony 1376, "8 SEP 1157", "6 APR 1199", # Richard I Coeur de Lion 1379, "OCT 1165", "4 SEP 1199", # Joan Plantagenet @@ -1446,7 +1452,7 @@ date_overrides <- tribble( 1960, "1282", "7 JUN 1337", # Gwenllian ferch Llywelyn 1961, "1223", "11 DEC 1282", # Llywelyn ap Gruffudd 1964, "849", "26 OCT 899", # Alfred the Great; - # birth year sometimes given 847-849, selected 849 + # birth year sometimes given 847-849, selected 849 1965, "852", "5 DEC 902", # Ealhswith of Mercia 1966, "795", "13 JAN 858", # Æthelwulf of Wessex 1968, "825", "852", # Æthelstan of Kent @@ -1484,7 +1490,7 @@ date_overrides <- tribble( 2050, "672", "718", # Ingild of Wessex 2051, "670", "31 AUG 725", # Cuthburh of Wimborne 2053, "630", "14 DEC 705", # Aldfrith of Northumbria - #; death year varies 704/705, selected 705 + # ; death year varies 704/705, selected 705 2054, "758", "784", # Ealhmund of Kent and death year 2057, "1307", "26 SEP 1345", # William II of Hainault 2058, "1314", "26 DEC 1360", # Thomas Holland, 1st Earl of Kent @@ -1561,7 +1567,7 @@ date_overrides <- tribble( 2146, "29 MAY 1773", "29 NOV 1844", # Sophia of Gloucester; identity inferred from Gloucester/Walpole context 2147, "23 FEB 1708", "5 JUN 1752", # Charles Louis Frederick of Mecklenburg-Strelitz 2148, "4 AUG 1713", "29 JUN 1761", # Elisabeth Albertine of Saxe-Hildburghausen - 2149, "26 JAN 1935", NA_character_, #Helen Louise Kirby. Countess Dvinskaya + 2149, "26 JAN 1935", NA_character_, # Helen Louise Kirby. Countess Dvinskaya 2150, "13 SEP 1794", "12 APR 1860", # Ernest I of Hohenlohe-Langenburg 2152, "11 OCT 1957", NA_character_, # Katharine Fraser; living 2155, "9 AUG 1914", "26 APR 1943", # Alastair Arthur of Connaught, 2nd Duke of Connaught @@ -1569,6 +1575,8 @@ date_overrides <- tribble( 2158, "6 NOV 1892", "8 APR 1938", # George Mountbatten, 2nd Marquess of Milford Haven; likely duplicate/identity match to personID 102 2159, "9 MAR 1963", NA_character_, # Ivar Mountbatten; living 2160, "13 SEP 1867", "3 JUL 1939", # Wilfrid Ashley, 1st Baron Mount Temple + 2162, "19 OCT 1910", "31 MAR 1989", # Hamilton Joseph Keyes O'Malley (Q75382629) + 2166, "1205", "1257", # Maelgwn Fychan and death year 2168, "1210", "1265", # Maredudd ap Owain and death year 2169, "1240", "1275", # Owain ap Maredudd and death year @@ -1935,7 +1943,7 @@ date_overrides <- tribble( 2593, "850", "8 DEC 899", # Arnulf of Carinthia 2594, "873", "903", # Oda of Bavaria and death after/about 903 2595, "893", "24 SEP 911", # Louis the Child; - # death date varies 20/24 SEP 911, selected 24 SEP + # death date varies 20/24 SEP 911, selected 24 SEP 2596, "870", "13 AUG 900", # Zwentibold 2597, "850", "24 DEC 903", # Hedwiga of Babenberg 2598, "851", "30 NOV 912", # Otto of Saxony / Otto the Illustrious @@ -2057,6 +2065,8 @@ date_overrides <- tribble( 2780, "10 APR 1916", "22 DEC 2019", # Dagmar Bernadotte af Wisborg 2781, "12 JUL 1921", "3 NOV 2018", # Oscar Bernadotte af Wisborg 2782, "10 JAN 1926", NA_character_, # Catharina Bernadotte af Wisborg; living or death not found in this pass + 2789, "10 AUG 1934", NA_character_, # Miles Carl Flach + 2790, "22 DEC 1960", NA_character_, # Jana Camilla Flach 2829, "25 JUN 1899", "4 JAN 1977", # Margaretha of Sweden / Princess Axel of Denmark 2830, "12 AUG 1888", "14 JUL 1964", # Axel of Denmark 2831, "7 FEB 1904", "15 APR 1991", # Elsa von Rosen @@ -2096,7 +2106,7 @@ date_overrides <- tribble( 2876, "19 MAY 1797", "26 DEC 1818", # Maria Isabel of Portugal / Queen of Spain 2877, "6 DEC 1803", "18 MAY 1829", # Maria Josepha Amalia of Saxony / Queen of Spain 2878, "11 NOV 1748", "20 JAN 1819", # Charles IV of Spain; - # some sources give death as 19 JAN 1819 + # some sources give death as 19 JAN 1819 2879, "9 DEC 1751", "2 JAN 1819", # Maria Luisa of Parma / Queen of Spain 2880, "20 JAN 1716", "14 DEC 1788", # Charles III of Spain 2881, "24 NOV 1724", "27 SEP 1760", # Maria Amalia of Saxony / Queen of Spain @@ -2184,39 +2194,30 @@ date_overrides <- tribble( 2998, "4 JAN 1912", "29 MAY 1940", # Anthony Cartland 3009, NA_character_, NA_character_, # blanking the infant Cartland row for now 3010, "31 DEC 1939", NA_character_ # Glen McCorquodale - ) # notes: -# 1051 likely duplicates the Andreas of Leiningen already represented at personID == 911. -#1125 likely duplicates Jean of Luxembourg already represented at personID == 586. - -# Non-date cautions surfaced while auditing: # 1801: the row title says “King of Denmark,” but the likely identity is Sihtric Cáech/Sihtric of Northumbria or Dublin. I included the date data and noted the title/identity caution in the comment. -#1847: likely Isabel de Warenne based on the Balliol/Warenne placement, but the row’s given name alone is underspecified. I included the date data and flagged the inference. - - - -#1975: likely duplicates or variant-matches 1968 Æthelstan of Kent. I included the date data and flagged it. +# 1847: likely Isabel de Warenne based on the Balliol/Warenne placement, but the row’s given name alone is underspecified. I included the date data and flagged the inference. -#2065 likely duplicates the Catherine Swynford branch already represented elsewhere. +# 1975: likely duplicates or variant-matches 1968 Æthelstan of Kent. I included the date data and flagged it. -#2158 likely duplicates George Mountbatten already represented at personID == 102. +# 2065 likely duplicates the Catherine Swynford branch already represented elsewhere. -#2215 has a current death-year pattern that may not match the most likely identification as Murchad mac Diarmata; I included the date data and flagged the identity concern. -#2269 is listed only as “of Burgundy,” but the most likely identity in context is Philip the Bold, Duke of Burgundy. I included the date data and flagged that inference. +# 2158 likely duplicates George Mountbatten already represented at personID == 102. -#2279 likely duplicates Edmund Stafford already represented at personID == 2070. +# 2215 has a current death-year pattern that may not match the most likely identification as Murchad mac Diarmata; I included the date data and flagged the identity concern. -#2288 likely duplicates John Hastings already represented at personID == 1417. +# 2269 is listed only as “of Burgundy,” but the most likely identity in context is Philip the Bold, Duke of Burgundy. I included the date data and flagged that inference. -#2300 likely duplicates John Neville, Lord Latimer already represented at personID == 863. +# 2279 likely duplicates Edmund Stafford already represented at personID == 2070. +# 2288 likely duplicates John Hastings already represented at personID == 1417. # 2359 likely duplicates Thomas Howard, 4th Duke of Norfolk, already represented at personID == 2326. @@ -2238,15 +2239,9 @@ date_overrides <- tribble( # 2689, 2690: likely duplicate/identity matches to the Württemberg/Brandenburg-Schwedt parents already represented at personID == 1067 and 1068. # 2839 is listed as Mary, but the row clearly matches Marie Bonaparte through the father Roland Bonaparte and the marriage to Prince George of Greece. -# 2867, 2868, and 2872 required approximate mid-month values because the available date information was month-level. I used parse-compatible dates and marked them as approximate. - -# 2878 Charles IV has a one-day death-date discrepancy. I used 20 JAN 1819, while noting that some sources give 19 JAN 1819. - -# 2921 appears to be Marie Louise Élisabeth d’Orléans, Duchess of Berry. The current row’s death-year placeholder appears to be wrong, so I used 21 JUL 1719. # 2964, 2965, and 2967 resolve the Greek/Yugoslav branch: Olga of Greece and Denmark, Prince Paul of Yugoslavia, and Elizabeth of Greece and Denmark. -# 3009 is only identifiable as an infant Cartland row in this pass, so I used year-level dates only rather than fabricating precision. name_overrides <- tribble( ~personID, ~name_override, @@ -2643,6 +2638,7 @@ name_overrides <- tribble( 2158, "George Mountbatten", 2159, "Ivar Mountbatten", 2160, "Wilfrid Ashley", + 2162, "Hamilton Joseph Keyes-O'Malley", 2169, "Owain ap Maredudd", 2170, "Llywelyn ap Owain", 2171, "Thomas ap Llywelyn", @@ -2920,6 +2916,8 @@ name_overrides <- tribble( 2780, "Dagmar Bernadotte af Wisborg", 2781, "Oscar Bernadotte af Wisborg", 2782, "Catharina Bernadotte af Wisborg", + 2789, "Miles Carl Flach", + 2790, "Jana Camilla Flach", 2829, "Margaretha of Sweden", 2832, "Madeleine Bernadotte af Wisborg", 2839, "Marie Bonaparte", @@ -3063,8 +3061,10 @@ royal92_cleaned <- royal92 %>% personID == 201 ~ "Duke of Argyll", personID == 224 ~ "Princess of Battenberg; Princess of Erbach-Schönberg", personID %in% - c(230, 2839, - 2842, 2845) ~ "Princess of Greece and Denmark", + c( + 230, 2839, + 2842, 2845 + ) ~ "Princess of Greece and Denmark", personID == 240 ~ "Lady McCorquodale", personID == 241 ~ "Lady Fellowes", personID %in% @@ -3100,12 +3100,14 @@ royal92_cleaned <- royal92 %>% personID %in% c(453, 2234) ~ "Queen of Norway", personID %in% - c(474, 1828, 2416, + c( + 474, 1828, 2416, 2443, 2449, 2485, 2508, 2615, 2618, 2633, 2858, 2864, 2876, 2877, 2879, - 2881, 2883, 2887, 2888) ~ "Queen", + 2881, 2883, 2887, 2888 + ) ~ "Queen", personID == 479 ~ "Margrave of Baden", personID == 484 ~ "Duke of Württemberg", personID %in% @@ -3120,9 +3122,11 @@ royal92_cleaned <- royal92 %>% personID == 531 ~ "Grand Duke of Tuscany", personID == 578 ~ "Duke of Nassau", personID %in% - c(590, 751, + c( + 590, 751, 2501, - 2515, 2516) ~ "Duke of Orléans", + 2515, 2516 + ) ~ "Duke of Orléans", personID == 591 ~ "Duke of Segovia", personID == 593 ~ "Duchess of Soria", personID == 594 ~ "Infante of Spain", @@ -3157,31 +3161,44 @@ royal92_cleaned <- royal92 %>% c(863) ~ "Baron Latimer", personID == 864 ~ "Baron Seymour", personID %in% - c(871, 1929, + c( + 871, 1929, 2291, 2418, 2419, 2420, 2430, 2431, - 2433, 2434) ~ "Holy Roman Emperor", - personID %in% c(873, 2315, - 2953, 2954) ~ "Earl of Leicester", - personID %in% c(876, 1883, - 2217, 2288, 2332) ~ "Earl of Pembroke", + 2433, 2434 + ) ~ "Holy Roman Emperor", + personID %in% c( + 873, 2315, + 2953, 2954 + ) ~ "Earl of Leicester", + personID %in% c( + 876, 1883, + 2217, 2288, 2332 + ) ~ "Earl of Pembroke", personID == 877 ~ "Crown Prince of Yugoslavia", personID %in% - c(914) ~ "Grand Duchess of Russia", + c(914) ~ "Grand Duchess of Russia", personID == 932 ~ "Princess of Prussia", personID == 1051 ~ NA_character_, + personID == 1125 ~ NA_character_, personID == 1250 ~ "Earl of Bothwell", personID %in% c(1373, 1867) ~ "Count of Poitiers", personID == 1385 ~ "Abbess", personID %in% - c(1473, 1476, - 1492, 1494) ~ "Earl of Arran", + c( + 1473, 1476, + 1492, 1494 + ) ~ "Earl of Arran", + personID %in% + c( + 1588, 1834, + 1877, 1890, + 2295 + ) ~ "Earl of Gloucester", personID %in% - c(1588, 1834, - 1877, 1890, - 2295) ~ "Earl of Gloucester", + c(1706, 2162, 2789) ~ "Captain", personID == 1802 ~ "wife of Edward the Elder", personID == 1804 ~ "son of Edward the Elder", personID == 1811 ~ "King of West Francia", @@ -3205,8 +3222,10 @@ royal92_cleaned <- royal92 %>% personID %in% c(1897, 2470) ~ "Count of Dreux", personID %in% - c(1904, 1906, - 2280, 2283) ~ "Earl of March", + c( + 1904, 1906, + 2280, 2283 + ) ~ "Earl of March", personID %in% c(1907, 1908) ~ "Baron Mortimer", personID == 1914 ~ "Marquess Wellesley", @@ -3248,14 +3267,18 @@ royal92_cleaned <- royal92 %>% personID == 2160 ~ "Baron Mount Temple", personID == 2180 ~ "Lord Rhys", personID %in% - c(2191, 2192, - 2193, 2194) ~ "Baron Inchiquin", + c( + 2191, 2192, + 2193, 2194 + ) ~ "Baron Inchiquin", personID %in% c(2195, 2202) ~ "King of Thomond", personID == 2218 ~ "Countess of Pembroke", personID %in% - c(2269, 2426, - 2518, 2533) ~ "Duke of Burgundy", + c( + 2269, 2426, + 2518, 2533 + ) ~ "Duke of Burgundy", personID == 2270 ~ "Count of Saint-Pol", personID == 2271 ~ "Earl Rivers", personID == 2278 ~ "Lord Cherleton", @@ -3307,7 +3330,7 @@ royal92_cleaned <- royal92 %>% personID == 2396 ~ "Lord Beauchamp", personID == 2397 ~ "Baron Seymour of Trowbridge", personID %in% - c(2403,2963) ~ "Lady", + c(2403, 2963) ~ "Lady", personID == 2407 ~ "Earl of Banbury", personID == 2414 ~ "Lord Offaly", personID == 2427 ~ "Electress", @@ -3329,7 +3352,7 @@ royal92_cleaned <- royal92 %>% personID == 2578 ~ "son of Charles the Bald", personID == 2632 ~ "Baron Geddes", personID %in% - c(2634, 2875) ~ "Princess of Asturias", + c(2634, 2875) ~ "Princess of Asturias", personID == 2637 ~ "Princess of Bourbon-Two Sicilies", personID == 2638 ~ "Viscount de la Torre", personID == 2642 ~ "Countess Marone-Cinzano", @@ -3352,7 +3375,7 @@ royal92_cleaned <- royal92 %>% personID == 2889 ~ "Prince of Asturias", personID == 2890 ~ "Prince of Portugal", personID %in% - c(2892, 2913) ~ "Duchess of Savoy", + c(2892, 2913) ~ "Duchess of Savoy", personID == 2893 ~ "Duke of Savoy", personID == 2900 ~ "Duke of Vendôme", personID == 2904 ~ "Prince Napoléon", @@ -3372,7 +3395,7 @@ royal92_cleaned <- royal92 %>% personID == 2956 ~ "Earl of Albemarle", personID == 2964 ~ "Princess of Yugoslavia", personID == 2965 ~ "Prince of Yugoslavia", - personID == 3009 ~ NA_character_, #Blanking + personID == 3009 ~ NA_character_, # Blanking TRUE ~ attribute_title ), twinID = case_when( @@ -3411,15 +3434,19 @@ royal92_cleaned <- royal92 %>% ) ~ "F", TRUE ~ sex ), - name = str_replace_all(name, text_cleanup_regex) %>% + name = str_replace_all( + name, + text_cleanup_regex + ) %>% str_squish() ) royal92 <- royal92_cleaned %>% select(personID, momID, dadID, - famID, twinID, name, sex, - birth_date, death_date, - title = attribute_title) + famID, twinID, name, sex, + birth_date, death_date, + title = attribute_title + ) checkis_acyclic <- checkPedigreeNetwork(royal92, personID = "personID", @@ -3436,24 +3463,32 @@ if (checkis_acyclic$is_acyclic) { message("The pedigree contains cyclic relationships.") } -if(FALSE){ - - library(ggpedigree) +if (FALSE) { + library(ggpedigree) royal92_famid <- royal92 %>% group_by(famID) %>% group_split() -ggped<- ggPedigreeInteractive(royal92_famid[[1]], - personID = "personID", - momID = "momID", - dadID = "dadID", - twinID = "twinID", - config = list( - code_male = "M", - code_female = "F", - add_phantoms = TRUE - ) - ) - + royal92_trimmed1 <- + royal92_famid[[1]] %>% trimPedigree( + personID = "personID", + momID = "momID", + dadID = "dadID", + max_iter = 2 + ) + ggped <- ggPedigreeInteractive(royal92_trimmed1, + personID = "personID", + momID = "momID", + dadID = "dadID", + twinID = "twinID", + config = list( + code_male = "M", + code_female = "F", + add_phantoms = TRUE, + ped_packed = TRUE, + ped_align = TRUE + ), + tooltip_columns = c("personID", "name", "title", "birth_date", "death_date") + ) } diff --git a/data-raw/gedcom_spec.R b/data-raw/gedcom_spec.R new file mode 100644 index 00000000..1276903f --- /dev/null +++ b/data-raw/gedcom_spec.R @@ -0,0 +1,25 @@ +# Downloads the FamilySearch GEDCOM 7 spec TSVs and saves them as sysdata. +# Run once with: source("data-raw/gedcom_spec.R") + +base_url <- "https://raw.githubusercontent.com/FamilySearch/GEDCOM/main/extracted-files/" + +gedcom_substructures <- utils::read.table( + paste0(base_url, "substructures.tsv"), + sep = "\t", header = TRUE, stringsAsFactors = FALSE, quote = "" +) +gedcom_payloads <- utils::read.table( + paste0(base_url, "payloads.tsv"), + sep = "\t", header = TRUE, stringsAsFactors = FALSE, quote = "" +) +gedcom_enumerations <- utils::read.table( + paste0(base_url, "enumerations.tsv"), + sep = "\t", header = TRUE, stringsAsFactors = FALSE, quote = "" +) + +usethis::use_data( + gedcom_substructures, + gedcom_payloads, + gedcom_enumerations, + internal = TRUE, + overwrite = TRUE +) diff --git a/data-raw/royal92.csv b/data-raw/royal92.csv index de19e33f..b8e31b97 100644 --- a/data-raw/royal92.csv +++ b/data-raw/royal92.csv @@ -1123,7 +1123,7 @@ personID,momID,dadID,famID,twinID,name,sex,birth_date,death_date,title 1122,NA,NA,90,NA,Umberto II,M,1904-09-15,1983-03-18,King of Italy 1123,599,600,1,NA,Josephine Charlotte,F,1927-10-11,2005-01-10,NA 1124,599,600,1,NA,Albert,M,1934-06-06,NA,Prince of Liege -1125,NA,NA,91,NA,Jean of Luxembourg,M,1921-01-05,2019-04-23,Grand Duke +1125,NA,NA,91,NA,TODO,U,1921-06-15,NA,NA 1126,NA,NA,92,NA,Fabiola de Mora y Aragon,F,1928-06-11,2014-12-05,NA 1127,NA,NA,1,NA,Paola di Calabria Ruffo,F,1937-09-11,NA,NA 1128,1127,1124,1,NA,Philippe,M,1960-04-15,NA,NA @@ -1704,7 +1704,7 @@ personID,momID,dadID,famID,twinID,name,sex,birth_date,death_date,title 1703,1425,1424,1,NA,Marie Therese of Angouleme,F,1778-12-19,1851-10-19,Duchess 1704,514,417,27,NA,Pepin the Hunchback,M,769-06-15,811-06-15,NA 1705,NA,NA,1,NA,Marie Amelie of Bourbon,F,1782-04-26,1866-03-24,Queen of France -1706,123,126,1,NA,Alexander of Mar Ramsay,M,1919-12-21,2000-12-20,Capt. +1706,123,126,1,NA,Alexander of Mar Ramsay,M,1919-12-21,2000-12-20,Captain 1707,NA,NA,1,NA,Flora Fraser,F,1930-10-18,NA,Lady 1708,NA,NA,166,NA,Dorothy Hastings,F,1899-06-15,NA,NA 1709,NA,NA,167,NA,Henry Somerset,M,1900-04-04,1984-02-04,Duke of Beaufort @@ -2160,7 +2160,7 @@ personID,momID,dadID,famID,twinID,name,sex,birth_date,death_date,title 2159,2156,504,1,NA,Ivar Mountbatten,M,1963-03-09,NA,Lord 2160,NA,NA,1,NA,Wilfrid Ashley,M,1867-09-13,1939-07-03,Baron Mount Temple 2161,NA,NA,1,NA,of Lodesborough,M,NA,NA,Earl -2162,NA,NA,238,NA,J. Keyes-O'Malley Hamilton,M,NA,NA,Capt. +2162,NA,NA,238,NA,Hamilton Joseph Keyes-O'Malley,M,1910-10-19,1989-03-31,Captain 2163,NA,NA,1,NA,Michael Kelly Bryan,M,NA,NA,NA 2164,NA,NA,239,NA,William Kemp,M,NA,NA,NA 2165,509,2163,1,NA,Robin Alexander,M,NA,NA,NA @@ -2787,8 +2787,8 @@ personID,momID,dadID,famID,twinID,name,sex,birth_date,death_date,title 2786,2780,2783,1,NA,Catherine von Arbin,F,1946-06-15,NA,NA 2787,2780,2783,1,NA,Jeanette von Arbin,F,1951-06-15,NA,NA 2788,2780,2783,1,NA,Madeleine von Arbin,F,1955-06-15,NA,NA -2789,NA,NA,1,NA,Miles Flach,M,1934-06-15,NA,Capt. -2790,2784,2789,1,NA,Camilla Flach,F,1960-06-15,NA,NA +2789,NA,NA,1,NA,Miles Carl Flach,M,1934-08-10,NA,Captain +2790,2784,2789,1,NA,Jana Camilla Flach,F,1960-12-22,NA,NA 2791,NA,NA,1,NA,Dick Bergstrom,M,1936-06-15,NA,NA 2792,2785,2791,1,NA,Therese Bergstrom,F,1963-06-15,NA,NA 2793,2785,2791,1,NA,Michael Bergstrom,M,1965-06-15,NA,NA diff --git a/data/royal92.rda b/data/royal92.rda index 785e6ae6..035c546e 100644 Binary files a/data/royal92.rda and b/data/royal92.rda differ diff --git a/man/addMaternalChain.Rd b/man/addMaternalChain.Rd new file mode 100644 index 00000000..458ec8f5 --- /dev/null +++ b/man/addMaternalChain.Rd @@ -0,0 +1,59 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/addParentalChain.R +\name{addMaternalChain} +\alias{addMaternalChain} +\title{Add maternal ancestor chains to a pedigree} +\usage{ +addMaternalChain( + ped, + personID = "personID", + dadID = "dadID", + momID = "momID", + chain_col = "momID_chain", + chain_string_col = "momID_chain_string", + collapse = "|", + traversal_direction = "in" +) +} +\arguments{ +\item{ped}{A pedigree data frame.} + +\item{personID}{Character string giving the name of the column containing +individual IDs.} + +\item{dadID}{Character string giving the name of the column containing +paternal IDs.} + +\item{momID}{Character string giving the name of the column containing +maternal IDs.} + +\item{chain_col}{Character string giving the name of the output list-column +that will contain the ordered parental ancestor chain for each individual.} + +\item{chain_string_col}{Character string giving the name of the output +character column that will contain the collapsed parental ancestor chain.} + +\item{collapse}{Character string used to collapse ancestor IDs into +`chain_string_col`.} + +\item{traversal_direction}{Character giving the mode of transversion: defaults to "in". If set to out, will procedure a list of descendants.} +} +\value{ +A data frame with two added columns: + \describe{ + \item{`chain_col`}{A list-column containing the ordered maternal ancestor + chain for each individual.} + \item{`chain_string_col`}{A character column containing the collapsed + maternal ancestor chain, or `NA_character_` when no maternal ancestors are + found.} + } +} +\description{ +Adds an ordered maternal ancestor chain for each individual in a pedigree. +The chain follows only mother-to-mother links, so the resulting chain is: +mother, maternal grandmother, maternal great-grandmother, and so on. +} +\details{ +This is a convenience wrapper around [addParentalChain()] with +`component = "momID"`. +} diff --git a/man/addMaternalLineFlag.Rd b/man/addMaternalLineFlag.Rd new file mode 100644 index 00000000..d49e9b92 --- /dev/null +++ b/man/addMaternalLineFlag.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/addParentalChain.R +\name{addMaternalLineFlag} +\alias{addMaternalLineFlag} +\title{Add a maternal-line descendant flag to a pedigree} +\usage{ +addMaternalLineFlag(ped, anchor_id, flag_col, chain_col = "momID_chain") +} +\arguments{ +\item{ped}{A pedigree data frame containing a parental chain list-column.} + +\item{anchor_id}{ID of the anchor individual to search for within each +person's parental chain.} + +\item{flag_col}{Character string giving the name of the logical output column +to add to `ped`.} + +\item{chain_col}{Character string giving the name of the list-column +containing ordered parental ancestor chains.} +} +\value{ +A data frame with `flag_col` added. The flag is `TRUE` when + `anchor_id` appears in the individual's selected parental chain and `FALSE` + otherwise. +} +\description{ +Adds a logical flag indicating whether a specified anchor individual appears +anywhere in each person's ordered maternal ancestor chain. +} +\details{ +This is a convenience wrapper around [addParentalLineFlag()] with +`component = "momID"`. +} diff --git a/man/addParentalChain.Rd b/man/addParentalChain.Rd new file mode 100644 index 00000000..c119d272 --- /dev/null +++ b/man/addParentalChain.Rd @@ -0,0 +1,82 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/addParentalChain.R +\name{addParentalChain} +\alias{addParentalChain} +\title{Add unilineal parental ancestor chains to a pedigree} +\usage{ +addParentalChain( + ped, + personID = "personID", + dadID = "dadID", + momID = "momID", + chain_col = "chain", + chain_string_col = "chain_string", + collapse = "|", + component = c("dadID", "momID"), + traversal_direction = "in" +) +} +\arguments{ +\item{ped}{A pedigree data frame.} + +\item{personID}{Character string giving the name of the column containing +individual IDs.} + +\item{dadID}{Character string giving the name of the column containing +paternal IDs.} + +\item{momID}{Character string giving the name of the column containing +maternal IDs.} + +\item{chain_col}{Character string giving the name of the output list-column +that will contain the ordered parental ancestor chain for each individual.} + +\item{chain_string_col}{Character string giving the name of the output +character column that will contain the collapsed parental ancestor chain.} + +\item{collapse}{Character string used to collapse ancestor IDs into +`chain_string_col`.} + +\item{component}{Character string specifying which parental component to +follow. Must be either `"dadID"` for paternal chains or `"momID"` for +maternal chains.} + +\item{traversal_direction}{Character giving the mode of transversion: defaults to "in". If set to out, will procedure a list of descendants.} +} +\value{ +A data frame with two added columns: + \describe{ + \item{`chain_col`}{A list-column containing the ordered unilineal parental + ancestor chain for each individual.} + \item{`chain_string_col`}{A character column containing the collapsed + ancestor chain, or `NA_character_` when no ancestors are found in the + selected component.} + } +} +\description{ +Adds an ordered unilineal parental ancestor chain for each individual in a +pedigree. The chain can follow either paternal links only or maternal links +only. +} +\details{ +For `component = "dadID"`, the chain follows: +father, paternal grandfather, paternal great-grandfather, and so on. + +For `component = "momID"`, the chain follows: +mother, maternal grandmother, maternal great-grandmother, and so on. + +The function constructs a parent-specific version of the pedigree, converts it +to a graph using [ped2graph()], identifies reachable ancestors for each +individual, orders those ancestors by graph distance from the focal +individual, and adds both a list-column representation and a collapsed string +representation to the original pedigree. + + +All pedigree IDs used to construct the parent-specific graph are coerced to +character. Individuals that are not represented as graph vertices receive an +empty chain in `chain_col` and `NA_character_` in `chain_string_col`. + +The ordering of each chain is based on graph distance from the focal +individual, where distance 1 is the selected parent, distance 2 is the +selected parent's same-component parent, and so forth. +} diff --git a/man/addParentalLineFlag.Rd b/man/addParentalLineFlag.Rd new file mode 100644 index 00000000..c0c0cce5 --- /dev/null +++ b/man/addParentalLineFlag.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/addParentalChain.R +\name{addParentalLineFlag} +\alias{addParentalLineFlag} +\title{Add a unilineal parental-line descendant flag to a pedigree} +\usage{ +addParentalLineFlag( + ped, + anchor_id, + flag_col, + chain_col, + component = c("dadID", "momID") +) +} +\arguments{ +\item{ped}{A pedigree data frame containing a parental chain list-column.} + +\item{anchor_id}{ID of the anchor individual to search for within each +person's parental chain.} + +\item{flag_col}{Character string giving the name of the logical output column +to add to `ped`.} + +\item{chain_col}{Character string giving the name of the list-column +containing ordered parental ancestor chains.} + +\item{component}{Character string specifying which parental component the +chain represents. Must be either `"dadID"` for paternal chains or `"momID"` +for maternal chains.} +} +\value{ +A data frame with `flag_col` added. The flag is `TRUE` when + `anchor_id` appears in the individual's selected parental chain and `FALSE` + otherwise. +} +\description{ +Adds a logical flag indicating whether a specified anchor individual appears +anywhere in each person's ordered unilineal parental ancestor chain. +} +\details{ +For `component = "dadID"`, the function searches the paternal chain. +For `component = "momID"`, the function searches the maternal chain. + + +The anchor ID is coerced to character before comparison because the chain +columns produced by [addParentalChain()] store graph vertex names as character +values. + +This function assumes that `chain_col` is a list-column in which each element +is a character vector of ancestor IDs. Empty chains should be represented as +`character(0)`. +} diff --git a/man/addPaternalChain.Rd b/man/addPaternalChain.Rd new file mode 100644 index 00000000..28b723fb --- /dev/null +++ b/man/addPaternalChain.Rd @@ -0,0 +1,55 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/addParentalChain.R +\name{addPaternalChain} +\alias{addPaternalChain} +\title{This is a convenience wrapper around [addParentalChain()] with +`component = "dadID"`.} +\usage{ +addPaternalChain( + ped, + personID = "personID", + dadID = "dadID", + momID = "momID", + chain_col = "dadID_chain", + chain_string_col = "dadID_chain_string", + collapse = "|", + traversal_direction = "in" +) +} +\arguments{ +\item{ped}{A pedigree data frame.} + +\item{personID}{Character string giving the name of the column containing +individual IDs.} + +\item{dadID}{Character string giving the name of the column containing +paternal IDs.} + +\item{momID}{Character string giving the name of the column containing +maternal IDs.} + +\item{chain_col}{Character string giving the name of the output list-column +that will contain the ordered parental ancestor chain for each individual.} + +\item{chain_string_col}{Character string giving the name of the output +character column that will contain the collapsed parental ancestor chain.} + +\item{collapse}{Character string used to collapse ancestor IDs into +`chain_string_col`.} + +\item{traversal_direction}{Character giving the mode of transversion: defaults to "in". If set to out, will procedure a list of descendants.} +} +\value{ +A data frame with two added columns: + \describe{ + \item{`chain_col`}{A list-column containing the ordered paternal ancestor + chain for each individual.} + \item{`chain_string_col`}{A character column containing the collapsed + paternal ancestor chain, or `NA_character_` when no paternal ancestors are + found.} + } +} +\description{ +This is a convenience wrapper around [addParentalChain()] with +`component = "dadID"`. +} diff --git a/man/addPaternalLineFlag.Rd b/man/addPaternalLineFlag.Rd new file mode 100644 index 00000000..45e16c88 --- /dev/null +++ b/man/addPaternalLineFlag.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/addParentalChain.R +\name{addPaternalLineFlag} +\alias{addPaternalLineFlag} +\title{Add a paternal-line descendant flag to a pedigree} +\usage{ +addPaternalLineFlag(ped, anchor_id, flag_col, chain_col = "dadID_chain") +} +\arguments{ +\item{ped}{A pedigree data frame containing a parental chain list-column.} + +\item{anchor_id}{ID of the anchor individual to search for within each +person's parental chain.} + +\item{flag_col}{Character string giving the name of the logical output column +to add to `ped`.} + +\item{chain_col}{Character string giving the name of the list-column +containing ordered parental ancestor chains.} +} +\value{ +A data frame with `flag_col` added. The flag is `TRUE` when + `anchor_id` appears in the individual's paternal chain and `FALSE` + otherwise. +} +\description{ +Adds a logical flag indicating whether a specified anchor individual appears +anywhere in each person's ordered paternal ancestor chain. +} +\details{ +This is a convenience wrapper around [addParentalLineFlag()] with +`component = "dadID"`. +} diff --git a/man/detectGedcomVersion.Rd b/man/detectGedcomVersion.Rd new file mode 100644 index 00000000..d218f287 --- /dev/null +++ b/man/detectGedcomVersion.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/helpReadGedcom.R +\name{detectGedcomVersion} +\alias{detectGedcomVersion} +\title{Detect GEDCOM Version from File Lines} +\usage{ +detectGedcomVersion(lines) +} +\arguments{ +\item{lines}{Character vector of lines from a GEDCOM file.} +} +\value{ +A string such as `"5.5.1"`, `"7.0"`, or `"unknown"`. +} +\description{ +Detect GEDCOM Version from File Lines +} +\keyword{internal} diff --git a/man/dot-findRowlessParents.Rd b/man/dot-findRowlessParents.Rd new file mode 100644 index 00000000..2bf63fcb --- /dev/null +++ b/man/dot-findRowlessParents.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/checkParents.R +\name{.findRowlessParents} +\alias{.findRowlessParents} +\title{Find Rowless Parents} +\usage{ +.findRowlessParents(ped) +} +\arguments{ +\item{ped}{A dataframe representing the pedigree data with columns 'ID', 'dadID', and 'momID'.} +} +\value{ +A character/numeric vector of rowless parent IDs (empty if none). +} +\description{ +Identifies IDs referenced in momID or dadID that have no row of their own in \code{ped}. +Used to detect parents (e.g., unrecorded founder stock) whose genetic contribution +cannot be traced because their own ancestry is absent from the pedigree. +} +\keyword{internal} diff --git a/man/fitPedigreeModel.Rd b/man/fitPedigreeModel.Rd index 628b1bde..152a1c5d 100644 --- a/man/fitPedigreeModel.Rd +++ b/man/fitPedigreeModel.Rd @@ -19,7 +19,8 @@ fitPedigreeModel( tryhard = TRUE, intervals = TRUE, extraTries = 10, - condenseMatrixSlots = TRUE + condenseMatrixSlots = TRUE, + runmodel = TRUE ) } \arguments{ @@ -57,6 +58,8 @@ if FALSE, use \code{mxRun}.} \item{extraTries}{Numeric. The number of extra optimization attempts to make when \code{tryhard} is TRUE. Default is 10.} \item{condenseMatrixSlots}{Logical. If TRUE, use the mxCondenseMatrixSlots wrapper to optimize memory usage for large matrices. Default is TRUE.} + +\item{runmodel}{Logical. If TRUE (default), the model is fitted; if FALSE, the model is returned without fitting.} } \value{ A fitted OpenMx model. diff --git a/man/gedcomLatToNumeric.Rd b/man/gedcomLatToNumeric.Rd new file mode 100644 index 00000000..b81ebced --- /dev/null +++ b/man/gedcomLatToNumeric.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/helpReadGedcom.R +\name{gedcomLatToNumeric} +\alias{gedcomLatToNumeric} +\title{Convert GEDCOM Latitude String to Numeric} +\usage{ +gedcomLatToNumeric(x) +} +\arguments{ +\item{x}{Character vector of GEDCOM latitude values.} +} +\value{ +Numeric vector of decimal degrees (positive = N, negative = S). +} +\description{ +Converts GEDCOM-style latitude strings like `"N51.5074"` or `"S33.8688"` to +signed decimal degrees. Returns `NA` for `NA` or unrecognised-prefix input. +} +\examples{ +BGmisc:::gedcomLatToNumeric(c("N51.5074", "S33.8688", NA)) +} +\keyword{internal} diff --git a/man/gedcomLonToNumeric.Rd b/man/gedcomLonToNumeric.Rd new file mode 100644 index 00000000..7914d7c0 --- /dev/null +++ b/man/gedcomLonToNumeric.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/helpReadGedcom.R +\name{gedcomLonToNumeric} +\alias{gedcomLonToNumeric} +\title{Convert GEDCOM Longitude String to Numeric} +\usage{ +gedcomLonToNumeric(x) +} +\arguments{ +\item{x}{Character vector of GEDCOM longitude values.} +} +\value{ +Numeric vector of decimal degrees (positive = E, negative = W). +} +\description{ +Converts GEDCOM-style longitude strings like `"E151.2093"` or `"W0.1278"` to +signed decimal degrees. Returns `NA` for `NA` or unrecognised-prefix input. +} +\examples{ +BGmisc:::gedcomLonToNumeric(c("E151.2093", "W0.1278", NA)) +} +\keyword{internal} diff --git a/man/ped2com.Rd b/man/ped2com.Rd index 900a1e7b..78d18b01 100644 --- a/man/ped2com.Rd +++ b/man/ped2com.Rd @@ -18,6 +18,8 @@ ped2com( keep_ids = NULL, adjacency_method = "direct", isChild_method = "partialparent", + repair_rowless_parents = FALSE, + rowless_parents_method = "rows", saveable = FALSE, resume = FALSE, save_rate = 5, @@ -61,6 +63,10 @@ ped2com( \item{isChild_method}{character. The method to use for computing the isChild matrix. Options are "classic" or "partialparent"} +\item{repair_rowless_parents}{logical. If TRUE, automatically correct for parents referenced in momID/dadID that have no row of their own in \code{ped} (e.g., unrecorded founder stock), before computing relatedness. Without this, such parents are still treated as "known" for the purposes of \code{isChild_method = "partialparent"} even though their genetic contribution cannot be traced, which understates diagonal relatedness and drops covariance between siblings who share the missing parent. How the correction is applied is controlled by \code{rowless_parents_method}. Defaults to FALSE, in which case a warning is issued instead.} + +\item{rowless_parents_method}{character. How to apply the \code{repair_rowless_parents} correction. \code{"rows"} (default) adds one placeholder founder row per unique missing parent ID (not one per affected child) to a working copy of \code{ped}, then restricts the returned matrix back to the original individuals via \code{keep_ids} unless \code{keep_ids} is already supplied. \code{"schur"} applies a Schur complement on the block-triangular RAM system -- for each missing parent, its already-known children define a rank-1 update (\code{v \%*\% t(v)}, where \code{v} is that parent's traced genetic contribution to every individual, computed from the existing RAM matrix) which is added to the relatedness matrix at the tcrossprod step. \code{"schur"} currently only supports \code{component = "additive"}.} + \item{saveable}{logical. If TRUE, save the intermediate results to disk} \item{resume}{logical. If TRUE, resume from a checkpoint} diff --git a/man/postProcessGedcom.Rd b/man/postProcessGedcom.Rd index f1449735..c91179e8 100644 --- a/man/postProcessGedcom.Rd +++ b/man/postProcessGedcom.Rd @@ -8,8 +8,9 @@ postProcessGedcom( df_temp, remove_empty_cols = TRUE, combine_cols = TRUE, - parse_dates = FALSE, add_parents = TRUE, + parse_dates = FALSE, + clean_names = TRUE, skinny = TRUE, verbose = FALSE ) @@ -19,13 +20,19 @@ postProcessGedcom( \item{remove_empty_cols}{Logical indicating whether to remove columns that are entirely missing.} -\item{combine_cols}{Logical indicating whether to combine columns with duplicate values.} +\item{combine_cols}{Logical. If `TRUE`, combine redundant name columns, such +as `name_given` with `name_given_pieces` and `name_surn` with +`name_surn_pieces`, when their values do not conflict.} + +\item{add_parents}{Logical. If `TRUE`, infer `momID` and `dadID` from `FAMC` +and `FAMS` mappings during post-processing.} -\item{parse_dates}{Logical indicating whether to parse date columns into Date objects.} +\item{parse_dates}{Logical. If `TRUE`, attempt to parse date columns (e.g., `birth_date`, `death_date`) into Date objects, after removing common GEDCOM date qualifiers like "ABT", "BEF", and "AFT".} -\item{add_parents}{Logical indicating whether to add parent information.} +\item{clean_names}{Logical indicating whether to clean name columns by removing trailing slashes and squishing whitespace.} -\item{skinny}{Logical indicating whether to slim down the data frame.} +\item{skinny}{Logical. If `TRUE`, return a slimmer data frame by dropping +`FAMC`, `FAMS`, and columns that are entirely `NA` during post-processing.} \item{verbose}{Logical indicating whether to print progress messages.} } diff --git a/man/processEventLine.Rd b/man/processEventLine.Rd index d4cff3d3..40bb9417 100644 --- a/man/processEventLine.Rd +++ b/man/processEventLine.Rd @@ -18,10 +18,9 @@ processEventLine(event, block, i, record, pattern_rows) \item{pattern_rows}{A list with counts of GEDCOM tag occurrences.} } \value{ -The updated record with parsed event information.# +The updated record with parsed event information. } \description{ Extracts event details (e.g., date, place, cause, latitude, longitude) from a block of GEDCOM lines. -For "birth": expect DATE on line i+1, PLAC on i+2, LATI on i+4, LONG on i+5. -For "death": expect DATE on line i+1, PLAC on i+2, CAUS on i+3, LATI on i+4, LONG on i+5. +Uses level-aware sub-block parsing so fields are looked up by tag name rather than fixed offsets. } diff --git a/man/readGedcom.Rd b/man/readGedcom.Rd index 2350716b..63cd9079 100644 --- a/man/readGedcom.Rd +++ b/man/readGedcom.Rd @@ -9,39 +9,42 @@ readGedcom( file_path, verbose = FALSE, + post_process = TRUE, add_parents = TRUE, remove_empty_cols = TRUE, combine_cols = TRUE, skinny = FALSE, parse_dates = FALSE, + clean_names = TRUE, update_rate = 1000, - post_process = TRUE, ... ) readGed( file_path, verbose = FALSE, + post_process = TRUE, add_parents = TRUE, remove_empty_cols = TRUE, combine_cols = TRUE, skinny = FALSE, parse_dates = FALSE, + clean_names = TRUE, update_rate = 1000, - post_process = TRUE, ... ) readgedcom( file_path, verbose = FALSE, + post_process = TRUE, add_parents = TRUE, remove_empty_cols = TRUE, combine_cols = TRUE, skinny = FALSE, parse_dates = FALSE, + clean_names = TRUE, update_rate = 1000, - post_process = TRUE, ... ) } @@ -50,11 +53,13 @@ readgedcom( \item{verbose}{Logical. If `TRUE`, print progress messages.} +\item{post_process}{Logical. If `TRUE`, apply post-processing steps controlled +by `add_parents`, `combine_cols`, `remove_empty_cols`, `skinny`, and `parse_dates`.} + \item{add_parents}{Logical. If `TRUE`, infer `momID` and `dadID` from `FAMC` and `FAMS` mappings during post-processing.} -\item{remove_empty_cols}{Logical. If `TRUE`, drop columns that are entirely -`NA` during post-processing.} +\item{remove_empty_cols}{Logical indicating whether to remove columns that are entirely missing.} \item{combine_cols}{Logical. If `TRUE`, combine redundant name columns, such as `name_given` with `name_given_pieces` and `name_surn` with @@ -65,12 +70,11 @@ as `name_given` with `name_given_pieces` and `name_surn` with \item{parse_dates}{Logical. If `TRUE`, attempt to parse date columns (e.g., `birth_date`, `death_date`) into Date objects, after removing common GEDCOM date qualifiers like "ABT", "BEF", and "AFT".} +\item{clean_names}{Logical indicating whether to clean name columns by removing trailing slashes and squishing whitespace.} + \item{update_rate}{Numeric. Intended rate at which progress messages should be printed. Currently unused.} -\item{post_process}{Logical. If `TRUE`, apply post-processing steps controlled -by `add_parents`, `combine_cols`, `remove_empty_cols`, `skinny`, and `parse_dates`.} - \item{...}{Additional arguments. Currently unused.} } \value{ @@ -139,12 +143,14 @@ cleaned full name. Additional name components are parsed when present, including name prefix, name suffix, nickname, and married surname. Birth and death events are recognized from `BIRT` and `DEAT` tags. Event -details are currently parsed using fixed offsets within the individual block. -For birth events, the parser expects `DATE` at `i + 1`, `PLAC` at `i + 2`, -`LATI` at `i + 4`, and `LONG` at `i + 5`. For death events, the parser -expects `DATE` at `i + 1`, `PLAC` at `i + 2`, `CAUS` at `i + 3`, `LATI` at -`i + 4`, and `LONG` at `i + 5`. Missing elements leave the corresponding -output fields as `NA`. +details are parsed by collecting all child lines whose GEDCOM level equals +the event level plus one (direct children), then looking up sub-fields by +tag name. `DATE`, `PLAC`, and `CAUS` are matched as direct children of the +event. Coordinates (`LATI` and `LONG`) are searched across all descendant +lines, which allows them to be located whether they appear as direct children +(common in some GEDCOM 5.5.x exporters), under `PLAC` (standard GEDCOM +5.5.1), or under a `MAP` substructure under `PLAC` (GEDCOM 7.x). Missing +sub-fields leave the corresponding output columns as `NA`. Attribute tags such as `OCCU`, `EDUC`, `RELI`, `CAST`, `NCHI`, `NMR`, `NATI`, `RESI`, `PROP`, `SSN`, `TITL`, `DSCR`, and `IDNO` are parsed directly into diff --git a/tests/testthat/test-addParentalChain.R b/tests/testthat/test-addParentalChain.R new file mode 100644 index 00000000..1ede74fb --- /dev/null +++ b/tests/testthat/test-addParentalChain.R @@ -0,0 +1,344 @@ +get_one <- function(x, id_col, id) { + idx <- which(x[[id_col]] == id) + testthat::expect_length(idx, 1) + idx +} + +get_chain <- function(x, id_col, id, chain_col) { + x[[chain_col]][[get_one(x, id_col, id)]] +} + +get_value <- function(x, id_col, id, value_col) { + x[[value_col]][get_one(x, id_col, id)] +} + + +test_that("addPaternalChain adds ordered paternal chains", { + ped <- data.frame( + personID = c("ego", "dad", "pat_gf", "pat_ggf", "mom", "mat_gm"), + dadID = c("dad", "pat_gf", "pat_ggf", NA, NA, NA), + momID = c("mom", NA, NA, NA, "mat_gm", NA), + stringsAsFactors = FALSE + ) + + result <- addPaternalChain(ped) + + expect_true("dadID_chain" %in% names(result)) + expect_true("dadID_chain_string" %in% names(result)) + + expect_identical( + get_chain(result, "personID", "ego", "dadID_chain"), + c("dad", "pat_gf", "pat_ggf") + ) + + expect_identical( + get_value(result, "personID", "ego", "dadID_chain_string"), + "dad|pat_gf|pat_ggf" + ) + + expect_identical( + get_chain(result, "personID", "pat_ggf", "dadID_chain"), + character(0) + ) + + expect_true( + is.na(get_value(result, "personID", "pat_ggf", "dadID_chain_string")) + ) +}) + + +test_that("addMaternalChain adds ordered maternal chains", { + ped <- data.frame( + personID = c("ego", "dad", "pat_gf", "mom", "mat_gm", "mat_ggm"), + dadID = c("dad", "pat_gf", NA, NA, NA, NA), + momID = c("mom", NA, NA, "mat_gm", "mat_ggm", NA), + stringsAsFactors = FALSE + ) + + result <- addMaternalChain(ped) + + expect_true("momID_chain" %in% names(result)) + expect_true("momID_chain_string" %in% names(result)) + + expect_identical( + get_chain(result, "personID", "ego", "momID_chain"), + c("mom", "mat_gm", "mat_ggm") + ) + + expect_identical( + get_value(result, "personID", "ego", "momID_chain_string"), + "mom|mat_gm|mat_ggm" + ) + + expect_identical( + get_chain(result, "personID", "mat_ggm", "momID_chain"), + character(0) + ) + + expect_true( + is.na(get_value(result, "personID", "mat_ggm", "momID_chain_string")) + ) +}) + + +test_that("addParentalChain can add paternal and maternal chains with custom output columns", { + ped <- data.frame( + personID = c("ego", "dad", "pat_gf", "mom", "mat_gm"), + dadID = c("dad", "pat_gf", NA, NA, NA), + momID = c("mom", NA, NA, "mat_gm", NA), + stringsAsFactors = FALSE + ) + + paternal_result <- addParentalChain( + ped = ped, + chain_col = "custom_pat_chain", + chain_string_col = "custom_pat_chain_string", + collapse = " > ", + component = "dadID" + ) + + maternal_result <- addParentalChain( + ped = ped, + chain_col = "custom_mat_chain", + chain_string_col = "custom_mat_chain_string", + collapse = " > ", + component = "momID" + ) + + expect_identical( + get_chain(paternal_result, "personID", "ego", "custom_pat_chain"), + c("dad", "pat_gf") + ) + + expect_identical( + get_value( + paternal_result, + "personID", + "ego", + "custom_pat_chain_string" + ), + "dad > pat_gf" + ) + + expect_identical( + get_chain(maternal_result, "personID", "ego", "custom_mat_chain"), + c("mom", "mat_gm") + ) + + expect_identical( + get_value( + maternal_result, + "personID", + "ego", + "custom_mat_chain_string" + ), + "mom > mat_gm" + ) +}) + + +test_that("addParentalChain works with custom input column names", { + ped <- data.frame( + id = c("ego", "dad", "pat_gf", "mom", "mat_gm"), + father = c("dad", "pat_gf", NA, NA, NA), + mother = c("mom", NA, NA, "mat_gm", NA), + stringsAsFactors = FALSE + ) + + result <- addParentalChain( + ped = ped, + personID = "id", + dadID = "father", + momID = "mother", + chain_col = "chain", + chain_string_col = "chain_string", + component = "dadID" + ) + + expect_identical( + get_chain(result, "id", "ego", "chain"), + c("dad", "pat_gf") + ) + + expect_identical( + get_value(result, "id", "ego", "chain_string"), + "dad|pat_gf" + ) +}) + + +test_that("addParentalChain coerces numeric IDs to character chains", { + ped <- data.frame( + personID = c(1, 2, 3, 4, 5), + dadID = c(2, 3, NA, NA, NA), + momID = c(4, NA, NA, 5, NA) + ) + + result <- addPaternalChain(ped) + + expect_identical( + get_chain(result, "personID", 1, "dadID_chain"), + c("2", "3") + ) + + expect_identical( + get_value(result, "personID", 1, "dadID_chain_string"), + "2|3" + ) +}) + + +test_that("addPaternalLineFlag flags whether anchor appears in paternal chain", { + ped <- data.frame( + personID = c("ego", "sibling", "dad", "pat_gf", "unrelated"), + stringsAsFactors = FALSE + ) + + ped$dadID_chain <- list( + c("dad", "pat_gf"), + c("dad", "pat_gf"), + c("pat_gf"), + character(0), + character(0) + ) + + result <- addPaternalLineFlag( + ped = ped, + anchor_id = "pat_gf", + flag_col = "descends_from_pat_gf" + ) + + expect_true("descends_from_pat_gf" %in% names(result)) + + expect_identical( + result$descends_from_pat_gf, + c(TRUE, TRUE, TRUE, FALSE, FALSE) + ) +}) + + +test_that("addMaternalLineFlag flags whether anchor appears in maternal chain", { + ped <- data.frame( + personID = c("ego", "sibling", "mom", "mat_gm", "unrelated"), + stringsAsFactors = FALSE + ) + + ped$momID_chain <- list( + c("mom", "mat_gm"), + c("mom", "mat_gm"), + c("mat_gm"), + character(0), + character(0) + ) + + result <- addMaternalLineFlag( + ped = ped, + anchor_id = "mat_gm", + flag_col = "descends_from_mat_gm" + ) + + expect_true("descends_from_mat_gm" %in% names(result)) + + expect_identical( + result$descends_from_mat_gm, + c(TRUE, TRUE, TRUE, FALSE, FALSE) + ) +}) + + +test_that("addParentalLineFlag works with explicit paternal and maternal chain columns", { + ped <- data.frame( + personID = c("ego", "dad", "mom", "pat_gf", "mat_gm", "unrelated"), + stringsAsFactors = FALSE + ) + + ped$dadID_chain <- list( + c("dad", "pat_gf"), + c("pat_gf"), + character(0), + character(0), + character(0), + character(0) + ) + + ped$momID_chain <- list( + c("mom", "mat_gm"), + character(0), + c("mat_gm"), + character(0), + character(0), + character(0) + ) + + paternal_result <- addParentalLineFlag( + ped = ped, + anchor_id = "pat_gf", + flag_col = "paternal_flag", + chain_col = "dadID_chain", + component = "dadID" + ) + + maternal_result <- addParentalLineFlag( + ped = ped, + anchor_id = "mat_gm", + flag_col = "maternal_flag", + chain_col = "momID_chain", + component = "momID" + ) + + expect_identical( + paternal_result$paternal_flag, + c(TRUE, TRUE, FALSE, FALSE, FALSE, FALSE) + ) + + expect_identical( + maternal_result$maternal_flag, + c(TRUE, FALSE, TRUE, FALSE, FALSE, FALSE) + ) +}) + + +test_that("addParentalLineFlag coerces numeric anchor IDs to character", { + ped <- data.frame( + personID = c(1, 2, 3, 4), + stringsAsFactors = FALSE + ) + + ped$dadID_chain <- list( + c("2", "3"), + c("3"), + character(0), + character(0) + ) + + result <- addPaternalLineFlag( + ped = ped, + anchor_id = 3, + flag_col = "has_ancestor_3" + ) + + expect_identical( + result$has_ancestor_3, + c(TRUE, TRUE, FALSE, FALSE) + ) +}) + + +test_that("addParentalLineFlag errors for invalid component", { + ped <- data.frame( + personID = c("ego"), + stringsAsFactors = FALSE + ) + + ped$dadID_chain <- list(character(0)) + + expect_error( + addParentalLineFlag( + ped = ped, + anchor_id = "x", + flag_col = "flag", + chain_col = "dadID_chain", + component = "invalid" + ) + ) +}) diff --git a/tests/testthat/test-readGedcom.R b/tests/testthat/test-readGedcom.R index ab11e915..a8102611 100644 --- a/tests/testthat/test-readGedcom.R +++ b/tests/testthat/test-readGedcom.R @@ -80,14 +80,14 @@ test_that("readGedcom reads and parses a GEDCOM file correctly", { expect_equal(nrow(df), 2) expect_equal(df$name_given[1], "John") expect_equal(df$name_surn[1], "Doe") - expect_equal(df$name[1], "John Doe/") + expect_equal(df$name[1], "John Doe") expect_equal(df$sex[1], "M") expect_equal(df$birth_date[1], "1 JAN 1900") expect_equal(df$birth_place[1], "Someplace") expect_equal(df$attribute_children[1], NA_character_) expect_equal(df$name_given[2], "Jane") expect_equal(df$name_surn[2], "Smith") - expect_equal(df$name[2], "Jane Smith/") + expect_equal(df$name[2], "Jane Smith") expect_equal(df$sex[2], "F") expect_equal(df$birth_date[2], "2 FEB 1910") expect_equal(df$birth_place[2], "Anotherplace") @@ -213,7 +213,7 @@ test_that("readGedcom parses death event correctly", { temp_file <- tempfile(fileext = ".ged") writeLines(gedcom_content, temp_file) - df <- readGedcom(temp_file, verbose = TRUE) + df <- readGedcom(temp_file, verbose = TRUE, clean_names = FALSE) expect_true("death_date" %in% colnames(df)) expect_true("death_place" %in% colnames(df)) @@ -243,6 +243,8 @@ test_that("readGedcom parses death event correctly", { row.names(df) <- NULL row.names(df_leg) <- NULL df_leg <- dplyr::rename(df_leg, personID = id) + # Strip the gedcom_version attribute added by readGedcom before comparing + attr(df, "gedcom_version") <- NULL expect_equal(df_leg, df) unlink(temp_file) @@ -352,7 +354,7 @@ test_that("readGedcom parses all supported name component tags", { expect_equal(df$name_nick[1], "Jack") expect_equal(df$name_surn_pieces[1], "Doe") expect_equal(df$name_nsfx[1], "Jr.") - expect_equal(df$name_marriedsurn[1], "John Quincy /MarriedDoe/") + expect_equal(df$name_marriedsurn[1], "John Quincy /MarriedDoe") unlink(temp_file) }) @@ -575,6 +577,121 @@ test_that("mapFAMS2parents warns and returns NULL when required columns are miss expect_null(out) }) +birt_no_date_content <- c( + "0 @I1@ INDI", + "1 NAME Alice /Jones/", + "1 SEX F", + "1 BIRT", + "2 PLAC Springfield", + "2 LATI N39.7817", + "2 LONG W89.6501" +) + +birt_no_plac_content <- c( + "0 @I1@ INDI", + "1 NAME Bob /Smith/", + "1 SEX M", + "1 BIRT", + "2 DATE 15 MAR 1955" +) + +birt_reordered_content <- c( + "0 @I1@ INDI", + "1 NAME Carol /Lee/", + "1 SEX F", + "1 BIRT", + "2 LATI N40.7128", + "2 LONG W74.0060", + "2 PLAC New York", + "2 DATE 4 JUL 1976" +) + +test_that("processEventLine handles missing DATE gracefully", { + temp_file <- tempfile(fileext = ".ged") + writeLines(birt_no_date_content, temp_file) + df <- readGedcom(temp_file, remove_empty_cols = FALSE) + expect_true(is.na(df$birth_date[1])) + expect_equal(df$birth_place[1], "Springfield") + expect_equal(df$birth_lat[1], "N39.7817") + expect_equal(df$birth_long[1], "W89.6501") + unlink(temp_file) +}) + +test_that("processEventLine handles missing PLAC gracefully", { + temp_file <- tempfile(fileext = ".ged") + writeLines(birt_no_plac_content, temp_file) + df <- readGedcom(temp_file, remove_empty_cols = FALSE) + expect_equal(df$birth_date[1], "15 MAR 1955") + expect_true(is.na(df$birth_place[1])) + unlink(temp_file) +}) + +test_that("processEventLine handles reordered subfields correctly", { + temp_file <- tempfile(fileext = ".ged") + writeLines(birt_reordered_content, temp_file) + df <- readGedcom(temp_file) + expect_equal(df$birth_date[1], "4 JUL 1976") + expect_equal(df$birth_place[1], "New York") + expect_equal(df$birth_lat[1], "N40.7128") + expect_equal(df$birth_long[1], "W74.0060") + unlink(temp_file) +}) + +gedcom55_header <- c( + "0 HEAD", + "1 GEDC", + "2 VERS 5.5.1", + "2 FORM LINEAGE-LINKED", + "1 CHAR UTF-8", + "0 @I1@ INDI", + "1 NAME Test /Person/", + "1 SEX M" +) + +gedcom7_header <- c( + "0 HEAD", + "1 GEDC", + "2 VERS 7.0", + "1 CHAR UTF-8", + "0 @I1@ INDI", + "1 NAME Test /Person/", + "1 SEX M" +) + +test_that("detectGedcomVersion returns correct version string", { + expect_equal(BGmisc:::detectGedcomVersion(gedcom55_header), "5.5.1") + expect_equal(BGmisc:::detectGedcomVersion(gedcom7_header), "7.0") + expect_equal(BGmisc:::detectGedcomVersion(c("0 @I1@ INDI", "1 NAME No /Head/")), "unknown") +}) + +test_that("readGedcom attaches gedcom_version attribute", { + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom55_header, temp_file) + df <- readGedcom(temp_file) + expect_equal(attr(df, "gedcom_version"), "5.5.1") + unlink(temp_file) +}) + +test_that("detectGedcomVersion returns unknown when GEDC is present but VERS is missing", { + lines <- c( + "0 HEAD", + "1 GEDC", + "1 CHAR UTF-8", + "0 @I1@ INDI", + "1 NAME Test /Person/", + "1 SEX M" + ) + expect_equal(BGmisc:::detectGedcomVersion(lines), "unknown") +}) + +test_that("readGedcom attaches gedcom_version attribute with post_process = FALSE", { + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom55_header, temp_file) + df <- readGedcom(temp_file, post_process = FALSE) + expect_equal(attr(df, "gedcom_version"), "5.5.1") + unlink(temp_file) +}) + test_that("readGed and readgedcom aliases return the same output as readGedcom", { gedcom_content <- c( "0 @I1@ INDI", @@ -598,3 +715,78 @@ test_that("readGed and readgedcom aliases return the same output as readGedcom", unlink(temp_file) }) + +gedcom7_map_content <- c( + "0 HEAD", + "1 GEDC", + "2 VERS 7.0", + "0 @I1@ INDI", + "1 NAME Test /Person/", + "1 SEX F", + "1 BIRT", + "2 DATE 1 JAN 2000", + "2 PLAC London, England", + "3 MAP", + "4 LATI N51.5074", + "4 LONG W0.1278", + "1 DEAT", + "2 DATE 31 DEC 2080", + "2 PLAC Edinburgh, Scotland", + "3 MAP", + "4 LATI N55.9533", + "4 LONG W3.1883" +) + +gedcom_calendar_escape_content <- c( + "0 HEAD", + "1 GEDC", + "2 VERS 5.5", + "0 @I1@ INDI", + "1 NAME Old /Style/", + "1 SEX M", + "1 BIRT", + "2 DATE @#DGREGORIAN@ 15 JUL 1823" +) + +test_that("readGedcom parses GEDCOM 7.x MAP coordinate structure", { + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom7_map_content, temp_file) + df <- readGedcom(temp_file) + expect_equal(attr(df, "gedcom_version"), "7.0") + expect_equal(df$birth_lat[1], "N51.5074") + expect_equal(df$birth_long[1], "W0.1278") + expect_equal(df$death_lat[1], "N55.9533") + expect_equal(df$death_long[1], "W3.1883") + unlink(temp_file) +}) + +test_that("parse_dates strips GEDCOM 5.5 calendar escape before parsing", { + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom_calendar_escape_content, temp_file) + df <- readGedcom(temp_file, parse_dates = TRUE) + expect_false(is.na(df$birth_date[1])) + expect_equal(format(df$birth_date[1], "%d %b %Y"), "15 Jul 1823") + unlink(temp_file) +}) + +test_that("gedcomLatToNumeric converts N/S notation correctly", { + expect_equal(gedcomLatToNumeric("N51.5074"), 51.5074) + expect_equal(gedcomLatToNumeric("S33.8688"), -33.8688) + expect_true(is.na(gedcomLatToNumeric(NA_character_))) +}) + +test_that("gedcomLonToNumeric converts E/W notation correctly", { + expect_equal(gedcomLonToNumeric("E151.2093"), 151.2093) + expect_equal(gedcomLonToNumeric("W0.1278"), -0.1278) + expect_true(is.na(gedcomLonToNumeric(NA_character_))) +}) + +test_that("gedcomLatToNumeric returns NA for unrecognised prefix", { + expect_true(is.na(gedcomLatToNumeric("12.34"))) + expect_true(is.na(gedcomLatToNumeric(""))) +}) + +test_that("gedcomLonToNumeric returns NA for unrecognised prefix", { + expect_true(is.na(gedcomLonToNumeric("12.34"))) + expect_true(is.na(gedcomLonToNumeric(""))) +}) diff --git a/tests/testthat/test-readGedcomlegacy.R b/tests/testthat/test-readGedcomlegacy.R index ea7a505c..181794d7 100644 --- a/tests/testthat/test-readGedcomlegacy.R +++ b/tests/testthat/test-readGedcomlegacy.R @@ -14,7 +14,10 @@ test_that("readGedcom parses death event correctly for legacy", { temp_file <- tempfile(fileext = ".ged") writeLines(gedcom_content, temp_file) - df <- readGedcom(temp_file, verbose = TRUE) + df <- readGedcom(temp_file, + verbose = TRUE, + clean_names = FALSE + ) df_leg <- .readGedcom.legacy(temp_file, verbose = TRUE) expect_true("death_date" %in% colnames(df_leg)) @@ -32,6 +35,8 @@ test_that("readGedcom parses death event correctly for legacy", { row.names(df) <- NULL row.names(df_leg) <- NULL df_leg <- dplyr::rename(df_leg, personID = id) + # Strip the gedcom_version attribute added by readGedcom before comparing + attr(df, "gedcom_version") <- NULL expect_equal(df_leg, df) unlink(temp_file) diff --git a/tests/testthat/test-rowlessParents.R b/tests/testthat/test-rowlessParents.R new file mode 100644 index 00000000..4a9dec5f --- /dev/null +++ b/tests/testthat/test-rowlessParents.R @@ -0,0 +1,110 @@ +ped_rowless <- data.frame( + ID = c("C1", "C2", "C3", "C4"), + momID = c("M1", "M1", "M1", NA), + dadID = c("D1", "D1", NA, NA), + sex = c(1, 0, 0, 1), + stringsAsFactors = FALSE +) +# M1 and D1 are referenced as parents but never appear as their own row +# (e.g., breeding stock imported from outside the recorded population). +# C1 & C2 are full sibs via M1+D1, C3 is a maternal half-sib via M1 only, +# C4 is an unrelated founder. + +test_that(".findRowlessParents identifies parent IDs with no row of their own", { + expect_equal(sort(.findRowlessParents(ped_rowless)), c("D1", "M1")) + expect_length(.findRowlessParents(data.frame(ID = "C1", momID = NA, dadID = NA)), 0) +}) + +test_that("ped2add warns when momID/dadID reference parents with no row", { + expect_warning( + ped2add(ped_rowless, sparse = FALSE), + "no matching row" + ) +}) + +test_that("repair_rowless_parents = TRUE fixes diagonal and sibling relatedness without warning, and does not grow the returned matrix", { + r <- expect_warning( + ped2add(ped_rowless, sparse = FALSE, repair_rowless_parents = TRUE), + NA + ) + + # Returned matrix stays at the original 4 individuals -- the placeholder + # founder rows added for M1/D1 are used internally but not returned. + expect_equal(sort(rownames(r)), c("C1", "C2", "C3", "C4")) + expect_equal(dim(r), c(4L, 4L)) + + # Diagonal should be 1 for everyone now, regardless of how many of their + # parents have their own row. + expect_equal(unname(diag(r)), rep(1, 4)) + + # Full sibs via the repaired M1+D1 founders + expect_equal(r["C1", "C2"], 0.5) + # Maternal half-sibs via the repaired M1 founder only + expect_equal(r["C1", "C3"], 0.25) + expect_equal(r["C2", "C3"], 0.25) + # Unrelated founder + expect_equal(r["C1", "C4"], 0) + expect_equal(r["C2", "C4"], 0) + expect_equal(r["C3", "C4"], 0) +}) + +test_that("repair_rowless_parents = TRUE is a no-op when there are no rowless parents", { + ped_complete <- potter + r_repaired <- ped2add(ped_complete, sparse = FALSE, repair_rowless_parents = TRUE) + r_plain <- ped2add(ped_complete, sparse = FALSE) + expect_equal(r_repaired, r_plain) +}) + +test_that("rowless_parents_method = 'schur' matches 'rows' exactly without adding any rows", { + r_rows <- ped2add(ped_rowless, sparse = FALSE, repair_rowless_parents = TRUE, rowless_parents_method = "rows") + # This toy pedigree has zero resolvable edges among the recorded individuals + # (every parent is rowless), which independently triggers a pre-existing, + # unrelated "empty isPar" warning regardless of rowless-parent handling -- + # suppress it here since it's not what this test is checking. + r_schur <- suppressWarnings( + ped2add(ped_rowless, sparse = FALSE, repair_rowless_parents = TRUE, rowless_parents_method = "schur") + ) + + expect_equal(dim(r_schur), c(4L, 4L)) + expect_equal(sort(rownames(r_schur)), c("C1", "C2", "C3", "C4")) + expect_equal( + r_schur[sort(rownames(r_schur)), sort(rownames(r_schur))], + r_rows[sort(rownames(r_rows)), sort(rownames(r_rows))] + ) + + expect_equal(unname(diag(r_schur)), rep(1, 4)) + expect_equal(r_schur["C1", "C2"], 0.5) + expect_equal(r_schur["C1", "C3"], 0.25) + expect_equal(r_schur["C2", "C3"], 0.25) + expect_equal(r_schur["C1", "C4"], 0) +}) + +test_that("rowless_parents_method = 'schur' propagates correctly to a grandchild generation", { + # F1 (rowless) -> C1 x D2 -> G1, G2 (full sibs); C1 x D3 -> G3 (paternal half-sib of G1/G2 via C1) + ped_deep <- data.frame( + ID = c("C1", "D2", "D3", "G1", "G2", "G3"), + momID = c("F1", NA, NA, "C1", "C1", "C1"), + dadID = c(NA, NA, NA, "D2", "D2", "D3"), + sex = c(0, 1, 1, 0, 1, 0), + stringsAsFactors = FALSE + ) + + r_rows <- ped2add(ped_deep, sparse = FALSE, repair_rowless_parents = TRUE, rowless_parents_method = "rows") + r_schur <- ped2add(ped_deep, sparse = FALSE, repair_rowless_parents = TRUE, rowless_parents_method = "schur") + + ids <- ped_deep$ID + expect_equal(r_schur[ids, ids], r_rows[ids, ids]) + expect_equal(unname(diag(r_schur)), rep(1, 6)) + expect_equal(r_schur["G1", "G2"], 0.5) + expect_equal(r_schur["G1", "G3"], 0.25) +}) + +test_that("rowless_parents_method = 'schur' errors for unsupported components", { + expect_error( + ped2com(ped_rowless, + component = "distance", sparse = FALSE, repair_rowless_parents = TRUE, + rowless_parents_method = "schur" + ), + "additive" + ) +}) diff --git a/tests/testthat/test-tweakPedigree.R b/tests/testthat/test-tweakPedigree.R index c9d9ac9b..588c78c7 100644 --- a/tests/testthat/test-tweakPedigree.R +++ b/tests/testthat/test-tweakPedigree.R @@ -97,7 +97,7 @@ test_that("makeTwins - dz Twins specified by generation", { # did it make the pair in the correct generation? expect_equal(mean(resultdz$gen[!is.na(resultdz$twinID)]), gen_twin) # how many sexes do we have? - sexes <- length(unique(resultdz$sex[!is.na(resultdz$twinID)])) + sexes <- length(unique(resultdz$sex[!is.na(resultdz$twinID)])) expect_lte(sexes, 2) expect_gte(sexes, 1) # are they from the same family?